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

LIB: various cleanups

Browse Source
This commit is contained in:
Julian Ospald 2016-04-06 03:10:07 +02:00
parent bad817d32d
commit 038b0d0377
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
5 changed files with 129 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -158,14 +158,19 @@ doesDirectoryExist fp =
return $ PF.isDirectory fs
-- |Checks whether the directory at the given path exists and can be
-- opened. This invokes `openDirStream`.
canOpenDirectory :: Path Abs -> IO Bool
canOpenDirectory fp =
handleIOError (\_ -> return False) $ do
dirstream <- PFD.openDirStream . P.fromAbs $ fp
PFD.closeDirStream dirstream
bracket (PFD.openDirStream . P.fromAbs $ fp)
PFD.closeDirStream
(\_ -> return ())
return True
-- |Throws a `Can'tOpenDirectory` FmIOException if the directory at the given
-- path cannot be opened.
throwCantOpenDirectory :: Path Abs -> IO ()
throwCantOpenDirectory fp =
unlessM (canOpenDirectory fp)
@ -194,6 +199,7 @@ catchErrno en a1 a2 =
else ioError e
-- |Like `catchIOError`, with arguments swapped.
handleIOError :: (IOError -> IO a) -> IO a -> IO a
handleIOError a1 a2 = catchIOError a2 a1

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

@ -32,12 +32,13 @@ module HSFM.FileSystem.FileOperations where
import Control.Exception
(
throw
, onException
bracket
, throw
)
import Control.Monad
(
unless
, void
)
import Data.ByteString
(
@ -185,7 +186,7 @@ copyDir cm from@(_ :/ Dir _ FileInfo{ fileMode = fmode })
createDestdir destdirp fmode
destdir <- HSFM.FileSystem.FileType.readFileWithFileInfo destdirp
contents <- readDirectoryContents' (fullPath from)
contents <- readDirectoryContentsWithFileInfo' (fullPath from)
for_ contents $ \f ->
case f of
@ -240,9 +241,7 @@ recreateSymlink _ _ _ _ = throw $ InvalidOperation "wrong input type"
-- |TODO: handle EAGAIN exception for non-blocking IO
-- TODO: implement for non-regular file? This would deprecate the logic
-- in copyDir
-- |Copies the given file to the given dir with the given filename.
-- |Copies the given regular file to the given dir with the given filename.
-- Excludes symlinks.
copyFile :: CopyMode
-> AnchoredFile FileInfo -- ^ source file
@ -265,16 +264,16 @@ copyFile cm from@(_ :/ RegFile {}) to@(_ :/ Dir {}) fn
throwCantOpenDirectory . fullPath $ to
fromFstatus <- getSymbolicLinkStatus (P.fromAbs from')
fromContent <- readFileContents from
fd <- SPI.createFile (P.fromAbs to')
(System.Posix.Files.ByteString.fileMode fromFstatus)
_ <- onException (fdWrite fd fromContent) (SPI.closeFd fd)
SPI.closeFd fd
bracket (SPI.createFile (P.fromAbs to')
$ System.Posix.Files.ByteString.fileMode fromFstatus)
SPI.closeFd
(\fd -> void $ fdWrite fd fromContent)
copyFile _ _ _ _ = throw $ InvalidOperation "wrong input type"
-- |Copies a file, directory or symlink. In case of a symlink, it is just
-- recreated, even if it points to a directory.
-- |Copies a regular file, directory or symlink. In case of a symlink,
-- it is just recreated, even if it points to a directory.
easyCopy :: CopyMode
-> AnchoredFile FileInfo
-> AnchoredFile FileInfo
@ -307,7 +306,7 @@ deleteSymlink f@(_ :/ SymLink {})
deleteSymlink _ = throw $ InvalidOperation "wrong input type"
-- |Deletes the given file, never symlinks.
-- |Deletes the given regular file, never symlinks.
deleteFile :: AnchoredFile FileInfo -> IO ()
deleteFile AFileInvFN = throw InvalidFileName
deleteFile f@(_ :/ RegFile {})
@ -329,7 +328,7 @@ deleteDirRecursive AFileInvFN = throw InvalidFileName
deleteDirRecursive f@(_ :/ Dir {}) = do
let fp = fullPath f
throwCantOpenDirectory fp
files <- readDirectoryContents' fp
files <- readDirectoryContentsWithFileInfo' fp
for_ files $ \file ->
case file of
(_ :/ SymLink {}) -> deleteSymlink file
@ -361,7 +360,8 @@ easyDelete _ = throw $ InvalidOperation "wrong input type"
--------------------
-- |Opens a file appropriately by invoking xdg-open.
-- |Opens a file appropriately by invoking xdg-open. The file type
-- is not checked.
openFile :: AnchoredFile a
-> IO ProcessID
openFile AFileInvFN = throw InvalidFileName
@ -376,6 +376,8 @@ executeFile :: AnchoredFile FileInfo -- ^ program
executeFile AFileInvFN _ = throw InvalidFileName
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 _ _ = throw $ InvalidOperation "wrong input type"
@ -386,6 +388,7 @@ executeFile _ _ = throw $ InvalidOperation "wrong input type"
---------------------
-- |Create an empty regular file at the given directory with the given filename.
createFile :: AnchoredFile FileInfo -> Path Fn -> IO ()
createFile AFileInvFN _ = throw InvalidFileName
createFile _ InvFN = throw InvalidFileName
@ -397,6 +400,7 @@ createFile (ADirOrSym td) (ValFN fn) = do
createFile _ _ = throw $ InvalidOperation "wrong input type"
-- |Create an empty directory at the given directory with the given filename.
createDir :: AnchoredFile FileInfo -> Path Fn -> IO ()
createDir AFileInvFN _ = throw InvalidFileName
createDir _ InvFN = throw InvalidFileName
@ -414,6 +418,7 @@ createDir _ _ = throw $ InvalidOperation "wrong input type"
----------------------------
-- |Rename a given file with the provided filename.
renameFile :: AnchoredFile FileInfo -> Path Fn -> IO ()
renameFile AFileInvFN _ = throw InvalidFileName
renameFile _ InvFN = throw InvalidFileName
@ -461,6 +466,7 @@ moveFile _ _ _ = throw $ InvalidOperation "wrong input type"
-----------------------
-- |Default permissions for a new file.
newFilePerms :: FileMode
newFilePerms
= ownerWriteMode
@ -471,6 +477,7 @@ newFilePerms
`unionFileModes` otherReadMode
-- |Default permissions for a new directory.
newDirPerms :: FileMode
newDirPerms
= ownerModes
@ -478,3 +485,4 @@ newDirPerms
`unionFileModes` groupReadMode
`unionFileModes` otherExecuteMode
`unionFileModes` otherReadMode

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

@ -21,7 +21,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
{-# OPTIONS_HADDOCK ignore-exports #-}
-- |This module provides data types for representing directories/files
-- and related operations on it, mostly internal stuff, not actual IO actions.
-- and related operations on it, mostly internal stuff.
--
-- It doesn't allow to represent the whole filesystem, since that's only
-- possible through IO laziness, which introduces too much internal state.
@ -44,6 +44,7 @@ import Control.Monad.State.Lazy
)
import Data.ByteString(ByteString)
import qualified Data.ByteString as B
import Data.Default
import Data.Time.Clock.POSIX
(
@ -60,11 +61,16 @@ import HPath
)
import qualified HPath as P
import HSFM.Utils.MyPrelude
import Prelude hiding(readFile)
import System.IO.Error
(
ioeGetErrorType
, isDoesNotExistErrorType
)
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
import System.Posix.Types
(
DeviceID
@ -77,11 +83,6 @@ import System.Posix.Types
, UserID
)
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
@ -117,7 +118,6 @@ data File a =
name :: Path Fn
, fvar :: a
}
-- TODO: add raw symlink dest (not normalized) to SymLink?
| SymLink {
name :: Path Fn
, fvar :: a
@ -143,7 +143,7 @@ data File a =
} deriving (Show, Eq)
-- |All possible file information we could ever need.
-- |Low-level file information.
data FileInfo = FileInfo {
deviceID :: DeviceID
, fileID :: FileID
@ -383,11 +383,11 @@ instance Ord (AnchoredFile FileInfo) where
-- anchor of `AnchoredFile` is always canonicalized.
--
-- Exceptions: when `canonicalizePath` fails, throws IOError
readWith :: (Path Abs -> IO a) -- ^ function that fills the free
readFile :: (Path Abs -> IO a) -- ^ function that fills the free
-- a variable
-> Path Abs -- ^ Path to read
-> IO (AnchoredFile a)
readWith ff p = do
readFile ff p = do
let fn = P.basename p
bd = P.dirname p
p' = P.toFilePath p
@ -410,7 +410,7 @@ readWith ff p = do
-- to something like '/' after normalization?
let sfp = (P.fromAbs bd') `P.combine` x
rsfp <- P.realPath sfp
readWith ff =<< P.parseAbs rsfp
readFile ff =<< P.parseAbs rsfp
return $ SymLink fn' fv resolvedSyml x
| PF.isDirectory fs = return $ Dir fn' fv
| PF.isRegularFile fs = return $ RegFile fn' fv
@ -421,40 +421,63 @@ readWith ff p = do
| otherwise = return $ Failed fn' (userError
"Unknown filetype!")
-- |Reads a file Path into an AnchoredFile.
readFile :: (Path Abs -> IO a) -> Path Abs -> IO (AnchoredFile a)
readFile ff fp = readWith ff fp
-- |Reads a file via `readFile` and fills the free variable via `getFileInfo`.
readFileWithFileInfo :: Path Abs -> IO (AnchoredFile FileInfo)
readFileWithFileInfo = HSFM.FileSystem.FileType.readFile getFileInfo
readFileWithFileInfo = readFile getFileInfo
-- |Same as readDirectoryContents but allows us to, for example, use
-- ByteString.readFile to return a tree of ByteStrings.
readDirectoryContents :: (Path Abs -> IO [Path Fn])
-> (Path Abs -> IO a)
-> Path Abs
-> IO [AnchoredFile a]
readDirectoryContents getfiles ff p = do
files <- getfiles p
fcs <- mapM (\x -> readFile ff $ p P.</> x) files
return $ removeNonexistent fcs
-- |Build a list of AnchoredFile, given the path to a directory, filling
-- the free variables via `getFileInfo`. This includes the "." and ".."
-- directories.
readDirectoryContents :: Path Abs -> IO [AnchoredFile FileInfo]
readDirectoryContents fp = readDirectoryContentsWith getAllDirsFiles getFileInfo fp
readDirectoryContentsWithFileInfo :: Path Abs -> IO [AnchoredFile FileInfo]
readDirectoryContentsWithFileInfo fp
= readDirectoryContents getAllDirsFiles getFileInfo fp
-- |Build a list of AnchoredFile, given the path to a directory, filling
-- the free variables via `getFileInfo`. This excludes the "." and ".."
-- directories.
readDirectoryContents' :: Path Abs -> IO [AnchoredFile FileInfo]
readDirectoryContents' fp = readDirectoryContentsWith getDirsFiles getFileInfo fp
readDirectoryContentsWithFileInfo' :: Path Abs -> IO [AnchoredFile FileInfo]
readDirectoryContentsWithFileInfo' fp
= readDirectoryContents getDirsFiles getFileInfo fp
-- |Same as readDirectoryContents but allows us to, for example, use
-- ByteString.readFile to return a tree of ByteStrings.
readDirectoryContentsWith :: (Path Abs -> IO [Path Fn])
-> (Path Abs -> IO a)
-> Path Abs
-> IO [AnchoredFile a]
readDirectoryContentsWith getfiles ff p = do
files <- getfiles p
fcs <- mapM (\x -> HSFM.FileSystem.FileType.readFile ff $ p P.</> x) files
return $ removeNonexistent fcs
-- |Get the contents of a directory, including "." and "..".
getContents :: AnchoredFile FileInfo
-> IO [AnchoredFile FileInfo]
getContents (ADirOrSym af) = readDirectoryContentsWithFileInfo (fullPath af)
getContents _ = return []
-- |Get the contents of a directory, including "." and "..".
getContents' :: AnchoredFile FileInfo
-> IO [AnchoredFile FileInfo]
getContents' (ADirOrSym af) = readDirectoryContentsWithFileInfo' (fullPath af)
getContents' _ = return []
-- |Go up one directory in the filesystem hierarchy.
goUp :: AnchoredFile FileInfo -> IO (AnchoredFile FileInfo)
goUp af@(Path "" :/ _) = return af
goUp (bp :/ _) = readFile getFileInfo bp
-- |Go up one directory in the filesystem hierarchy.
goUp' :: Path Abs -> IO (AnchoredFile FileInfo)
goUp' fp = readFile getFileInfo $ P.dirname fp
@ -467,22 +490,22 @@ readDirectoryContentsWith getfiles ff p = do
---- HANDLING FAILURES ----
-- | True if any Failed constructors in the tree
-- |True if any Failed constructors in the tree.
anyFailed :: [File a] -> Bool
anyFailed = not . successful
-- | True if there are no Failed constructors in the tree
-- |True if there are no Failed constructors in the tree.
successful :: [File a] -> Bool
successful = null . failures
-- | returns true if argument is a `Failed` constructor:
-- |Returns true if argument is a `Failed` constructor.
failed :: File a -> Bool
failed (Failed _ _) = True
failed _ = False
-- | returns a list of 'Failed' constructors only:
-- |Returns a list of 'Failed' constructors only.
failures :: [File a] -> [File a]
failures = filter failed
@ -515,14 +538,15 @@ comparingConstr t t' = compare (name t) (name t')
---------------------------
-- |Follows symbolic links.
-- |Reads a file and returns the content as a ByteString.
-- 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)
$ \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
@ -562,7 +586,6 @@ isCharC (CharDev _ _) = True
isCharC _ = False
isNamedC :: File a -> Bool
isNamedC (NamedPipe _ _) = True
isNamedC _ = False
@ -578,44 +601,29 @@ isSocketC _ = False
---- IO HELPERS: ----
-- |Go up one directory in the filesystem hierarchy.
goUp :: AnchoredFile FileInfo -> IO (AnchoredFile FileInfo)
goUp af@(Path "" :/ _) = return af
goUp (bp :/ _) = HSFM.FileSystem.FileType.readFile getFileInfo bp
-- |Go up one directory in the filesystem hierarchy.
goUp' :: Path Abs -> IO (AnchoredFile FileInfo)
goUp' fp = HSFM.FileSystem.FileType.readFile getFileInfo $ P.dirname fp
-- |Get the contents of a directory.
getContents :: AnchoredFile FileInfo
-> IO [AnchoredFile FileInfo]
getContents (ADirOrSym af) = readDirectoryContents (fullPath af)
getContents _ = return []
getDirsFiles' :: (Path Fn -> [Path Fn] -> [Path Fn])
-> Path Abs
-- |Gets all filenames of the given directory.
-- The first argument is a filter function that allows to exclude
-- filenames from the result.
getDirsFiles' :: (Path Fn -> [Path Fn] -> [Path Fn]) -- ^ filter function
-> Path Abs -- ^ dir to read
-> IO [Path Fn]
getDirsFiles' filterf fp = do
dirstream <- PFD.openDirStream . P.toFilePath $ fp
let mdirs :: [Path Fn] -> IO [Path Fn]
mdirs dirs = do
-- make sure we close the directory stream in case of errors
-- TODO: more explicit error handling?
-- both the parsing and readin the stream can fail!
dir <- onException (PFD.readDirStream dirstream)
(PFD.closeDirStream dirstream)
case dir of
"" -> return dirs
_ -> do
pdir <- P.parseFn dir
mdirs $ pdir `filterf` dirs
dirs <- mdirs []
PFD.closeDirStream dirstream
return dirs
getDirsFiles' filterf fp =
bracket (PFD.openDirStream . P.toFilePath $ fp)
PFD.closeDirStream
$ \dirstream ->
let mdirs :: [Path Fn] -> IO [Path Fn]
mdirs dirs = do
-- make sure we close the directory stream in case of errors
-- TODO: more explicit error handling?
-- both the parsing and readin the stream can fail!
dir <- onException (PFD.readDirStream dirstream)
(PFD.closeDirStream dirstream)
case dir of
"" -> return dirs
_ -> do
pdir <- P.parseFn dir
mdirs $ pdir `filterf` dirs
in mdirs []
-- |Get all files of a given directory and return them as a List.
@ -772,3 +780,4 @@ packPermissions dt = fromFreeVar (pStr . fileMode) dt
| hasFM fm = str
| otherwise = "-"
hasFM fm = ffm `PF.intersectFileModes` fm == fm

9
src/HSFM/Utils/IO.hs
View File

@ -1,6 +1,6 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
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
@ -18,6 +18,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
{-# OPTIONS_HADDOCK ignore-exports #-}
-- |Random and general IO utilities.
module HSFM.Utils.IO where
@ -39,17 +40,23 @@ import Control.Monad
)
-- |Atomically write a TVar.
writeTVarIO :: TVar a -> a -> IO ()
writeTVarIO tvar val = atomically $ writeTVar tvar val
-- |Atomically modify a TVar.
modifyTVarIO :: TVar a -> (a -> a) -> IO ()
modifyTVarIO tvar f = atomically $ modifyTVar tvar f
-- |If the value of the first argument is True, then execute the action
-- provided in the second argument, otherwise do nothing.
whenM :: Monad m => m Bool -> m () -> m ()
whenM mb a = mb >>= (`when` a)
-- |If the value of the first argument is False, then execute the action
-- provided in the second argument, otherwise do nothing.
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM mb a = mb >>= (`unless` a)

5
src/HSFM/Utils/MyPrelude.hs
View File

@ -1,6 +1,6 @@
{--
HSFM, a filemanager written in Haskell.
Copyright (C) 2015 Julian Ospald
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
@ -24,6 +24,9 @@ import Data.List
-- |Turns any list into a list of the same length with the values
-- being the indices.
-- E.g.: "abdasd" -> [0,1,2,3,4,5]
listIndices :: [a] -> [Int]
listIndices = findIndices (const True)