From 2486d832604e46491af33931f4a01a194c07abbf Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Tue, 22 Dec 2015 14:15:48 +0100 Subject: [PATCH] LIB/GTK: use AnchoredFile in IO.File What's the point of having it anyway if we don't? --- src/Data/DirTree.hs | 43 +++-- src/GUI/Gtk/Callbacks.hs | 76 +++------ src/GUI/Gtk/Utils.hs | 17 +- src/IO/File.hs | 352 +++++++++++++++++---------------------- 4 files changed, 215 insertions(+), 273 deletions(-) diff --git a/src/Data/DirTree.hs b/src/Data/DirTree.hs index 8d7058b..883ed48 100644 --- a/src/Data/DirTree.hs +++ b/src/Data/DirTree.hs @@ -251,14 +251,13 @@ readFileWith :: (FilePath -> IO a) -> FilePath -> IO (AnchoredFile a b) readFileWith fd ff fp = do - cfp <- canonicalizePath' fp - let fn = topDir cfp - bd = baseDir cfp - file <- handleDT fn $ do - isFile <- doesFileExist cfp + let fn = topDir fp + bd = baseDir fp + file <- handleDT (topDir fp) $ do + isFile <- doesFileExist fp if isFile - then RegFile fn <$> ff cfp - else Dir fn <$> fd cfp + then RegFile fn <$> ff fp + else Dir fn <$> fd fp return (bd :/ file) @@ -267,20 +266,30 @@ readFile fp = readFileWith getFileInfo getFileInfo =<< canonicalizePath' fp -- |Build a list of AnchoredFile, given the path to a directory, filling --- the free variables via `getFileInfo`. +-- the free variables via `getFileInfo`. This includes the "." and ".." +-- directories. readDirectory :: FilePath -> IO [AnchoredFile FileInfo FileInfo] -readDirectory fp = readDirectoryWith getFileInfo getFileInfo +readDirectory fp = readDirectoryWith getAllDirsFiles getFileInfo getFileInfo + =<< canonicalizePath' fp + + +-- |Build a list of AnchoredFile, given the path to a directory, filling +-- the free variables via `getFileInfo`. This excludes the "." and ".." +-- directories. +readDirectory' :: FilePath -> IO [AnchoredFile FileInfo FileInfo] +readDirectory' fp = readDirectoryWith getDirsFiles getFileInfo getFileInfo =<< canonicalizePath' fp -- | same as readDirectory but allows us to, for example, use -- ByteString.readFile to return a tree of ByteStrings. -readDirectoryWith :: (FilePath -> IO a) +readDirectoryWith :: (FilePath -> IO [FilePath]) + -> (FilePath -> IO a) -> (FilePath -> IO b) -> FilePath -> IO [AnchoredFile a b] -readDirectoryWith fd ff p = buildWith' buildAtOnce' fd ff - =<< canonicalizePath' p +readDirectoryWith getfiles fd ff p = buildWith' (buildAtOnce' getfiles) fd ff + =<< canonicalizePath' p @@ -314,12 +323,11 @@ buildWith' bf' fd ff p = -- IO function passed to our builder and finally executed here: -buildAtOnce' :: Builder a b -buildAtOnce' fd ff p = do - cfp <- canonicalizePath' p - contents <- getAllDirsFiles cfp +buildAtOnce' :: (FilePath -> IO [FilePath]) -> Builder a b +buildAtOnce' getfiles fd ff fp = do + contents <- getfiles fp for contents $ \n -> handleDT n $ do - let subf = cfp n + let subf = fp n do isFile <- doesFileExist subf if isFile then RegFile n <$> ff subf @@ -327,7 +335,6 @@ buildAtOnce' fd ff p = do - ----------------- --[ UTILITIES ]-- ----------------- diff --git a/src/GUI/Gtk/Callbacks.hs b/src/GUI/Gtk/Callbacks.hs index a2c7605..3e6c618 100644 --- a/src/GUI/Gtk/Callbacks.hs +++ b/src/GUI/Gtk/Callbacks.hs @@ -14,6 +14,10 @@ import Control.Concurrent.STM , newTVarIO , readTVarIO ) +import Control.Monad + ( + void + ) import Control.Monad.IO.Class ( liftIO @@ -63,10 +67,10 @@ setCallbacks mygui myview = do _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do [Control] <- eventModifier "h" <- fmap glibToString eventKeyName - mcdir <- liftIO $ getCwdFromFirstRow myview + mcdir <- liftIO $ getFirstRow myview liftIO $ modifyTVarIO (settings mygui) (\x -> x { showHidden = not . showHidden $ x}) - >> refreshTreeView mygui myview (Just mcdir) + >> refreshTreeView' mygui myview mcdir _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do [Alt] <- eventModifier "Up" <- fmap glibToString eventKeyName @@ -106,45 +110,16 @@ open row mygui myview = r@(_ :/ Dir _ _) -> do nv <- Data.DirTree.readFile $ fullPath r refreshTreeView' mygui myview nv - r@(_ :/ RegFile _ _) -> - withErrorDialog $ openFile $ fullPath r - _ -> return () + r -> + withErrorDialog $ openFile r -- |Supposed to be used with 'withRow'. Deletes a file or directory. del :: Row -> MyGUI -> MyView -> IO () -del row mygui myview = - case row of - r@(_ :/ Dir { dir = FileInfo { isSymbolicLink = True } }) -> - delSym r - r@(_ :/ RegFile { regFile = FileInfo { isSymbolicLink = True } }) -> - delSym r - r@(_ :/ Dir _ _) -> do - let fp = fullPath r - subADT <- readDirectory fp - let cmsg = "Really delete directory \"" ++ fp ++ "\"?" - cmsg2 = "Directory \"" ++ fp ++ - "\" is not empty! Delete all contents?" - withConfirmationDialog cmsg $ - if null subADT - then withErrorDialog (deleteDir fp - >> refreshTreeView mygui myview Nothing) - else withConfirmationDialog cmsg2 $ withErrorDialog - (deleteDirRecursive fp - >> refreshTreeView mygui myview Nothing) - r@(_ :/ RegFile _ _) -> do - let fp = fullPath r - cmsg = "Really delete file \"" ++ fp ++ "\"?" - withConfirmationDialog cmsg - $ withErrorDialog (deleteFile fp - >> refreshTreeView mygui myview Nothing) - where - delSym r = do - let fp = fullPath r - cmsg = "Really delete symlink \"" ++ fp ++ "\"?" - withConfirmationDialog cmsg - $ withErrorDialog (deleteSymlink fp - >> refreshTreeView mygui myview Nothing) +del row mygui myview = do + let cmsg = "Really delete \"" ++ fullPath row ++ "\"?" + withConfirmationDialog cmsg . withErrorDialog + $ easyDelete row >> refreshTreeView mygui myview Nothing -- |Supposed to be used with 'withRow'. Initializes a file copy operation. @@ -154,7 +129,7 @@ del row mygui myview = -- * 'operationBuffer' writes copyInit :: Row -> MyGUI -> MyView -> IO () copyInit row mygui myview = - writeTVarIO (operationBuffer myview) (FCopy . CP1 $ fullPath row) + writeTVarIO (operationBuffer myview) (FCopy . CP1 $ row) -- |Finalizes a file copy operation. @@ -165,17 +140,18 @@ copyInit row mygui myview = copyFinal :: MyGUI -> MyView -> IO () copyFinal mygui myview = do op <- readTVarIO (operationBuffer myview) - mcdir <- getCwdFromFirstRow myview + mcdir <- getFirstRow myview case op of - FCopy (CP1 source) -> do - let dest = mcdir - isFile <- doesFileExist source - let cmsg = "Really copy file \"" ++ source - ++ "\"" ++ " to \"" ++ dest ++ "\"?" - withConfirmationDialog cmsg $ do - copyMode <- if isFile then return Strict else showCopyModeChooserDialog - withErrorDialog ((runFileOp . FCopy . CC source dest $ copyMode) - >> refreshTreeView mygui myview Nothing) + FCopy (CP1 s) -> do + dest <- goUp mcdir + print dest + print s + let cmsg = "Really copy \"" ++ fullPath s + ++ "\"" ++ " to \"" ++ fullPath dest ++ "\"?" + withConfirmationDialog cmsg . withErrorDialog + $ (runFileOp (FCopy . CC s dest $ Strict) + >> refreshTreeView mygui myview Nothing) + return () _ -> return () @@ -187,8 +163,8 @@ copyFinal mygui myview = do -- * 'sortedModel' reads upDir :: MyGUI -> MyView -> IO () upDir mygui myview = do - mcdir <- getCwdFromFirstRow myview + mcdir <- getFirstRow myview rawModel' <- readTVarIO $ rawModel myview sortedModel' <- readTVarIO $ sortedModel myview - nv <- goUp' mcdir + nv <- goUp =<< goUp mcdir refreshTreeView' mygui myview nv diff --git a/src/GUI/Gtk/Utils.hs b/src/GUI/Gtk/Utils.hs index bf4eef9..de8848c 100644 --- a/src/GUI/Gtk/Utils.hs +++ b/src/GUI/Gtk/Utils.hs @@ -99,13 +99,12 @@ fileListStore dt myview = do -- Interaction with mutable references: -- -- * 'rawModel' reads -getCwdFromFirstRow :: MyView - -> IO FilePath -getCwdFromFirstRow myview = do +getFirstRow :: MyView + -> IO (AnchoredFile FileInfo FileInfo) +getFirstRow myview = do rawModel' <- readTVarIO $ rawModel myview iter <- fromJust <$> treeModelGetIterFirst rawModel' - af <- treeModelGetRow rawModel' iter - return $ anchor af + treeModelGetRow rawModel' iter -- |Re-reads the current directory or the given one and updates the TreeView. @@ -123,8 +122,8 @@ refreshTreeView :: MyGUI -> Maybe FilePath -> IO () refreshTreeView mygui myview mfp = do - mcdir <- getCwdFromFirstRow myview - let fp = fromMaybe mcdir mfp + mcdir <- getFirstRow myview + let fp = fromMaybe (anchor mcdir) mfp -- TODO catch exceptions dirSanityThrow fp @@ -170,10 +169,10 @@ constructTreeView mygui myview = do cMD' = cMD mygui render' = renderTxt mygui - mcdir <- getCwdFromFirstRow myview + mcdir <- getFirstRow myview -- update urlBar - entrySetText (urlBar mygui) mcdir + entrySetText (urlBar mygui) (anchor mcdir) rawModel' <- readTVarIO $ rawModel myview diff --git a/src/IO/File.hs b/src/IO/File.hs index 0b52794..875a070 100644 --- a/src/IO/File.hs +++ b/src/IO/File.hs @@ -77,23 +77,27 @@ import qualified System.Posix.Files as PF -- or delay operations. data FileOperation = FCopy Copy | FMove Move - | FDelete FilePath - | FOpen FilePath - | FExecute FilePath [String] + | FDelete (AnchoredFile FileInfo FileInfo) + | FOpen (AnchoredFile FileInfo FileInfo) + | FExecute (AnchoredFile FileInfo FileInfo) [String] | 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 FilePath - | CP2 FilePath FilePath - | CC FilePath FilePath DirCopyMode +data Copy = CP1 (AnchoredFile FileInfo FileInfo) + | CP2 (AnchoredFile FileInfo FileInfo) + (AnchoredFile FileInfo FileInfo) + | CC (AnchoredFile FileInfo FileInfo) + (AnchoredFile FileInfo FileInfo) + DirCopyMode -- |Data type describing partial or complete file move operation. -- MC stands for a complete operation and can be used for `runFileOp`. -data Move = MP1 FilePath - | MC FilePath FilePath +data Move = MP1 (AnchoredFile FileInfo FileInfo) + | MC (AnchoredFile FileInfo FileInfo) + (AnchoredFile FileInfo FileInfo) -- |Directory copy modes. @@ -142,34 +146,36 @@ runFileOp _ = return Nothing -- `removeDirectoryRecursive`, `recreateSymlink`, `copyDir`, -- `copyFileToDir`, `getDirectoryContents` throws copyDir :: DirCopyMode - -> FilePath -- ^ source dir - -> FilePath -- ^ destination dir + -> AnchoredFile FileInfo FileInfo -- ^ source dir + -> AnchoredFile FileInfo FileInfo -- ^ destination dir -> IO () -copyDir cm from' to' = do - from <- canonicalizePath' from' - to <- canonicalizePath' to' - onSymlinkOr from (copyFileToDir from to) (go from to) +copyDir cm from@(_ :/ Dir _ FileInfo { isSymbolicLink = True }) _ + = return () +copyDir cm from@(_ :/ Dir fromn _) + to@(_ :/ Dir {}) + = do + let fromp = fullPath from + top = fullPath to + destdirp = fullPath to fromn + print destdirp + throwDestinationInSource fromp destdirp + throwSameFile fromp destdirp + + createDestdir destdirp + destdir <- Data.DirTree.readFile destdirp + + contents <- readDirectory' (fullPath from) + + for_ contents $ \f -> + case f of + (_ :/ Dir _ FileInfo { isSymbolicLink = True }) -> + recreateSymlink f destdir + (_ :/ RegFile _ FileInfo { isSymbolicLink = True }) -> + recreateSymlink f destdir + (_ :/ Dir {}) -> copyDir cm f destdir + (_ :/ RegFile {}) -> copyFileToDir f destdir + _ -> return () where - go from to = do - let fn = takeFileName from - destdir = to fn - - dirSanityThrow from - dirSanityThrow to - throwDestinationInSource from to - throwSameFile from destdir - - createDestdir destdir - - contents <- getDirsFiles from - - for_ contents $ \f -> do - let ffn = from f - fs <- PF.getSymbolicLinkStatus ffn - case (PF.isSymbolicLink fs, PF.isDirectory fs) of - (True, _) -> recreateSymlink' destdir f ffn - (_, True) -> copyDir cm ffn destdir - (_, _) -> copyFileToDir ffn destdir createDestdir destdir = case cm of Merge -> @@ -180,31 +186,38 @@ copyDir cm from' to' = do Replace -> do whenM (doesDirectoryExist destdir) (removeDirectoryRecursive destdir) createDirectory destdir - recreateSymlink' destdir n f = do - let sympoint = destdir n + recreateSymlink' f destdir = do + let destfilep = fullPath destdir (name . file $ f) + destfile <- Data.DirTree.readFile destfilep _ <- case cm of -- delete old file/dir to be able to create symlink - Merge -> easyDelete sympoint + Merge -> easyDelete destfile _ -> return () - recreateSymlink f sympoint - + recreateSymlink f destdir +copyDir _ _ _ = return () -- |Recreate a symlink. -recreateSymlink :: FilePath -- ^ the old symlink file - -> FilePath -- ^ destination of the new symlink file +recreateSymlink :: AnchoredFile FileInfo FileInfo -- ^ the old symlink file + -> AnchoredFile FileInfo FileInfo -- ^ destination dir of the + -- new symlink file -> IO () -recreateSymlink symf' symdest' = do - symf <- canonicalizePath' symf' - symname <- readSymbolicLink symf - symdestd <- canonicalizePath' (baseDir symdest') - let symdest = symdestd takeFileName symdest' - createSymbolicLink symname symdest +recreateSymlink symf@(_ :/ RegFile n FileInfo { isSymbolicLink = True }) + symdest@(_ :/ Dir {}) + = do + symname <- readSymbolicLink (fullPath symf) + createSymbolicLink symname (fullPath symdest n) +recreateSymlink symf@(_ :/ Dir n FileInfo { isSymbolicLink = True }) + symdest@(_ :/ Dir {}) + = do + symname <- readSymbolicLink (fullPath symf) + createSymbolicLink symname (fullPath symdest n) +recreateSymlink _ _ = return () --- |Copies the given file. This can also be called on symlinks. +-- |Copies the given file to the given file destination. Not symlinks. -- -- The operation may fail with: -- @@ -215,44 +228,57 @@ recreateSymlink symf' symdest' = do -- * `PathNotAbsolute` if either of the filepaths are not absolute -- * `SameFile` if the source and destination files are the same -- * anything that `canonicalizePath` or `System.Directory.copyFile` throws -copyFile :: FilePath -- ^ source file - -> FilePath -- ^ destination file +copyFile :: AnchoredFile FileInfo FileInfo -- ^ source file + -> AnchoredFile FileInfo FileInfo -- ^ destination file -> IO () -copyFile from' to' = do - from <- canonicalizePath' from' - tod <- canonicalizePath' (baseDir to') - let to = tod takeFileName to' - onSymlinkOr from (recreateSymlink from to) $ do - fileSanityThrow from - throwNotAbsolute to - throwDirDoesExist to - toC <- canonicalizePath' (takeDirectory to) - let to' = toC takeFileName to - throwSameFile from to' - SD.copyFile from to' - +copyFile from@(_ :/ RegFile _ FileInfo { isSymbolicLink = True }) _ = return () +copyFile from@(_ :/ Dir _ FileInfo { isSymbolicLink = True }) _ = return () +copyFile from@(_ :/ RegFile {}) to@(_ :/ RegFile {}) = do + let from' = fullPath from + to' = fullPath to + throwSameFile from' to' + SD.copyFile from' to' +copyFile _ _ = return () -- |Copies the given file to the given dir with the same filename. -- This can also be called on symlinks. --- --- The operation may fail with: --- --- * `DirDoesNotExist` if the target directory does not exist --- * `PathNotAbsolute` if the target directory is not absolute --- * anything that `copyFile` throws -copyFileToDir :: FilePath -> FilePath -> IO () -copyFileToDir from' to' = do - from <- canonicalizePath' from' - to <- canonicalizePath' to' - let name = takeFileName from - dirSanityThrow to - copyFile from (to name) +copyFileToDir :: AnchoredFile FileInfo FileInfo + -> AnchoredFile FileInfo FileInfo + -> IO () +copyFileToDir from@(_ :/ RegFile _ FileInfo { isSymbolicLink = True }) _ + = return () +copyFileToDir from@(_ :/ Dir _ FileInfo { isSymbolicLink = True }) _ + = return () +copyFileToDir from@(_ :/ RegFile fn _) + to@(_ :/ Dir {}) = + do + let from' = fullPath from + to' = fullPath to fn + SD.copyFile from' to' +copyFileToDir _ _ = return () -easyCopy :: DirCopyMode -> FilePath -> FilePath -> IO () -easyCopy cm from to = onDirOrFile from (copyDir cm from to) - (copyFileToDir from to) +easyCopy :: DirCopyMode + -> AnchoredFile FileInfo FileInfo + -> AnchoredFile FileInfo FileInfo + -> IO () +easyCopy _ from@(_ :/ RegFile _ FileInfo { isSymbolicLink = True }) + to@(_ :/ Dir {}) + = recreateSymlink from to +easyCopy _ from@(_ :/ Dir _ FileInfo { isSymbolicLink = True }) + to@(_ :/ Dir {}) + = recreateSymlink from to +easyCopy _ from@(_ :/ RegFile fn _) + to@(_ :/ Dir {}) + = copyFileToDir from to +easyCopy _ from@(_ :/ RegFile fn _) + to@(_ :/ RegFile {}) + = copyFile from to +easyCopy cm from@(_ :/ Dir fn _) + to@(_ :/ Dir {}) + = copyDir cm from to +easyCopy _ _ _ = return () @@ -262,77 +288,57 @@ easyCopy cm from to = onDirOrFile from (copyDir cm from to) -- |Deletes a symlink, which can either point to a file or directory. --- --- The operation may fail with: --- --- * `dirSanityThrow` --- * `fileSanityThrow` -deleteSymlink :: FilePath -> IO () -deleteSymlink fp' = do - fp <- canonicalizePath' fp' - onDirOrFile fp (dirSanityThrow fp >> removeFile fp) - (fileSanityThrow fp >> removeFile fp) +deleteSymlink :: AnchoredFile FileInfo FileInfo -> IO () +deleteSymlink f@(_ :/ RegFile _ FileInfo { isSymbolicLink = True }) + = removeFile (fullPath f) +deleteSymlink f@(_ :/ Dir _ FileInfo { isSymbolicLink = True }) + = removeFile (fullPath f) +deleteSymlink _ + = return () --- |Deletes the given file. --- --- The operation may fail with: --- --- * `FileDoesNotExist` if the file does not exist --- * `PathNotAbsolute` if the file is not absolute --- * anything that `removeFile` throws -deleteFile :: FilePath -> IO () -deleteFile fp' = do - fp <- canonicalizePath' fp' - fileSanityThrow fp - throwIsSymlink fp - removeFile fp +-- |Deletes the given file, never symlinks. +deleteFile :: AnchoredFile FileInfo FileInfo -> IO () +deleteFile f@(_ :/ RegFile _ FileInfo { isSymbolicLink = True }) + = return () +deleteFile f@(_ :/ RegFile {}) + = removeFile (fullPath f) +deleteFile _ + = return () --- |Deletes the given directory. --- --- The operation may fail with: --- --- * `DirDoesNotExist` if the dir does not exist --- * `PathNotAbsolute` if the dir is not absolute --- * anything that `removeDirectory` throws -deleteDir :: FilePath -> IO () -deleteDir fp' = - onSymlinkOr fp' (deleteFile fp') $ do - fp <- canonicalizePath' fp' - dirSanityThrow fp - throwIsSymlink fp - removeDirectory fp +-- |Deletes the given directory, never symlinks. +deleteDir :: AnchoredFile FileInfo FileInfo -> IO () +deleteDir f@(_ :/ Dir _ FileInfo { isSymbolicLink = True }) + = return () +deleteDir f@(_ :/ Dir {}) + = removeDirectory (fullPath f) +deleteDir _ = return () --- |Deletes the given directory recursively. --- --- The operation may fail with: --- --- * `DirDoesNotExist` if the dir does not exist --- * `PathNotAbsolute` if the dir is not absolute --- * anything that `removeDirectoryRecursive` throws -deleteDirRecursive :: FilePath -> IO () -deleteDirRecursive fp' = - onSymlinkOr fp' (deleteFile fp') $ do - fp <- canonicalizePath' fp' - dirSanityThrow fp - throwIsSymlink fp - removeDirectoryRecursive fp +-- |Deletes the given directory recursively, never symlinks. +deleteDirRecursive :: AnchoredFile FileInfo FileInfo -> IO () +deleteDirRecursive f@(_ :/ Dir _ FileInfo { isSymbolicLink = True }) + = return () +deleteDirRecursive f@(_ :/ Dir {}) + = removeDirectoryRecursive (fullPath f) +deleteDirRecursive _ = return () -- |Deletes a file, directory or symlink, whatever it may be. --- --- The operation may fail with: --- --- * `DirDoesNotExist`/`FileDoesNotExist` if the file/dir does not exist --- * `PathNotAbsolute` if the file/dir is not absolute --- * anything that `deleteDir`/`deleteFile` throws -easyDelete :: FilePath -> IO () -easyDelete fp' = do - fp <- canonicalizePath' fp' - onSymlinkOr fp (deleteSymlink fp) $ - onDirOrFile fp (deleteDir fp) (deleteFile fp) +-- In case of directory, performs recursive deletion. +easyDelete :: AnchoredFile FileInfo FileInfo -> IO () +easyDelete f@(_ :/ RegFile _ FileInfo { isSymbolicLink = True }) + = deleteSymlink f +easyDelete f@(_ :/ Dir _ FileInfo { isSymbolicLink = True }) + = deleteSymlink f +easyDelete f@(_ :/ RegFile {}) + = deleteFile f +easyDelete f@(_ :/ Dir {}) + = deleteDirRecursive f +easyDelete _ + = return () + @@ -347,12 +353,9 @@ easyDelete fp' = do -- -- * `FileDoesNotExist` if the file does not exist -- * `PathNotAbsolute` if the file is not absolute -openFile :: FilePath +openFile :: AnchoredFile a b -> IO ProcessHandle -openFile fp' = do - fp <- canonicalizePath' fp' - fileSanityThrow fp - spawnProcess "xdg-open" [fp] +openFile f = spawnProcess "xdg-open" [fullPath f] -- |Executes a program with the given arguments. @@ -362,53 +365,10 @@ openFile fp' = do -- * `FileDoesNotExist` if the program does not exist -- * `PathNotAbsolute` if the program is not absolute -- * `FileNotExecutable` if the program is not executable -executeFile :: FilePath -- ^ program - -> [String] -- ^ arguments - -> IO ProcessHandle -executeFile prog' args = do - prog <- canonicalizePath' prog' - fileSanityThrow prog - unlessM (fileAccess prog False False True) (throw $ FileNotExecutable prog) - spawnProcess prog args - - - - - -------------------- - --[ Utilities ]-- - -------------------- - - --- |Carries out the given action if the filepath is a symlink. If not, --- carries out an alternative action. -onSymlinkOr :: FilePath - -> IO () -- ^ action if symlink - -> IO () -- ^ action if not symlink - -> IO () -onSymlinkOr fp a1 a2 = do - isSymlink <- PF.isSymbolicLink <$> PF.getSymbolicLinkStatus fp - if isSymlink then a1 else a2 - - --- |Executes either a directory or file related IO action, depending on --- the input filepath. --- --- The operation may fail with: --- --- * `throwFileDoesNotExist` if the filepath is neither a file or directory -onDirOrFile :: FilePath - -> IO () -- ^ action if directory - -> IO () -- ^ action if file - -> IO () -onDirOrFile fp' iod iof = do - fp <- canonicalizePath' fp' - isD <- doesDirectoryExist fp - isF <- doesFileExist fp - case (isD, isF) of - (True, False) -> do - dirSanityThrow fp - iod - (False, True) -> do - fileSanityThrow fp - iof - _ -> throwFileDoesNotExist fp +executeFile :: AnchoredFile FileInfo FileInfo -- ^ program + -> [String] -- ^ arguments + -> IO (Maybe ProcessHandle) +executeFile prog@(_ :/ RegFile _ FileInfo { permissions = perms }) args + | executable perms = Just <$> spawnProcess (fullPath prog) args + | otherwise = return Nothing +executeFile _ _ = return Nothing