diff --git a/src/HSFM/FileSystem/FileOperations.hs b/src/HSFM/FileSystem/FileOperations.hs index e49e8cd..ae62393 100644 --- a/src/HSFM/FileSystem/FileOperations.hs +++ b/src/HSFM/FileSystem/FileOperations.hs @@ -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,25 +236,26 @@ 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{} - fn' = do - fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (fullPathS from') - createDestdir (fullPath to' P. fn') fmode' + 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) - (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) - _ -> return () + 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 @@ -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. - catchErrno [eINVAL, eNOSYS] - (sendFileCopy (fullPathS from) (P.fromAbs to')) - (void $ fallbackCopy (fullPathS from) (P.fromAbs to')) + 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 = @@ -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) - _ -> throw $ FileDoesExist - (P.toFilePath . fullPath - $ 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" @@ -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' diff --git a/src/HSFM/FileSystem/FileType.hs b/src/HSFM/FileSystem/FileType.hs index 637ce38..ef1af5e 100644 --- a/src/HSFM/FileSystem/FileType.hs +++ b/src/HSFM/FileSystem/FileType.hs @@ -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) - $ return - . catMaybes - . fmap (\x -> (P.) fp <$> (parseMaybe . snd $ x)) - =<< getDirectoryContents (P.toFilePath fp) +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 @@ -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 diff --git a/src/HSFM/GUI/Gtk/Callbacks.hs b/src/HSFM/GUI/Gtk/Callbacks.hs index ff121a3..8b258c9 100644 --- a/src/HSFM/GUI/Gtk/Callbacks.hs +++ b/src/HSFM/GUI/Gtk/Callbacks.hs @@ -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) ++ "\"?" diff --git a/src/HSFM/GUI/Gtk/MyView.hs b/src/HSFM/GUI/Gtk/MyView.hs index 642dac7..c5c9a81 100644 --- a/src/HSFM/GUI/Gtk/MyView.hs +++ b/src/HSFM/GUI/Gtk/MyView.hs @@ -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 "/")