Nie możesz wybrać więcej, niż 25 tematów Tematy muszą się zaczynać od litery lub cyfry, mogą zawierać myślniki ('-') i mogą mieć do 35 znaków.
 
 
 
 

264 wiersze
7.9 KiB

  1. -- |
  2. -- Module : System.Posix.RawFilePath.Directory.Traversals
  3. -- Copyright : © 2016 Julian Ospald
  4. -- License : BSD3
  5. --
  6. -- Maintainer : Julian Ospald <hasufell@posteo.de>
  7. -- Stability : experimental
  8. -- Portability : portable
  9. --
  10. -- Traversal and read operations on directories.
  11. {-# LANGUAGE CPP #-}
  12. {-# LANGUAGE ForeignFunctionInterface #-}
  13. {-# LANGUAGE OverloadedStrings #-}
  14. {-# LANGUAGE TupleSections #-}
  15. {-# LANGUAGE ViewPatterns #-}
  16. {-# OPTIONS_GHC -Wall #-}
  17. module System.Posix.RawFilePath.Directory.Traversals (
  18. getDirectoryContents
  19. , getDirectoryContents'
  20. , allDirectoryContents
  21. , allDirectoryContents'
  22. , traverseDirectory
  23. -- lower-level stuff
  24. , readDirEnt
  25. , packDirStream
  26. , unpackDirStream
  27. , fdOpendir
  28. , realpath
  29. ) where
  30. #if __GLASGOW_HASKELL__ < 710
  31. import Control.Applicative ((<$>))
  32. #endif
  33. import Control.Monad
  34. import System.Posix.FilePath ((</>))
  35. import System.Posix.Foreign
  36. import qualified System.Posix as Posix
  37. import System.IO.Error
  38. import Control.Exception
  39. import qualified Data.ByteString.Char8 as BS
  40. import System.Posix.ByteString.FilePath
  41. import System.Posix.Directory.ByteString as PosixBS
  42. import System.Posix.Files.ByteString
  43. import System.IO.Unsafe
  44. import "unix" System.Posix.IO.ByteString (closeFd)
  45. import Unsafe.Coerce (unsafeCoerce)
  46. import Foreign.C.Error
  47. import Foreign.C.String
  48. import Foreign.C.Types
  49. import Foreign.Marshal.Alloc (alloca,allocaBytes)
  50. import Foreign.Ptr
  51. import Foreign.Storable
  52. ----------------------------------------------------------
  53. -- | Get all files from a directory and its subdirectories.
  54. --
  55. -- Upon entering a directory, 'allDirectoryContents' will get all entries
  56. -- strictly. However the returned list is lazy in that directories will only
  57. -- be accessed on demand.
  58. --
  59. -- Follows symbolic links for the input dir.
  60. allDirectoryContents :: RawFilePath -> IO [RawFilePath]
  61. allDirectoryContents topdir = do
  62. namesAndTypes <- getDirectoryContents topdir
  63. let properNames = filter ((`notElem` [".", ".."]) . snd) namesAndTypes
  64. paths <- forM properNames $ \(typ,name) -> unsafeInterleaveIO $ do
  65. let path = topdir </> name
  66. case () of
  67. () | typ == dtDir -> allDirectoryContents path
  68. | typ == dtUnknown -> do
  69. isDir <- isDirectory <$> getFileStatus path
  70. if isDir
  71. then allDirectoryContents path
  72. else return [path]
  73. | otherwise -> return [path]
  74. return (topdir : concat paths)
  75. -- | Get all files from a directory and its subdirectories strictly.
  76. --
  77. -- Follows symbolic links for the input dir.
  78. allDirectoryContents' :: RawFilePath -> IO [RawFilePath]
  79. allDirectoryContents' = fmap reverse . traverseDirectory (\acc fp -> return (fp:acc)) []
  80. -- this uses traverseDirectory because it's more efficient than forcing the
  81. -- lazy version.
  82. -- | Recursively apply the 'action' to the parent directory and all
  83. -- files/subdirectories.
  84. --
  85. -- This function allows for memory-efficient traversals.
  86. --
  87. -- Follows symbolic links for the input dir.
  88. traverseDirectory :: (s -> RawFilePath -> IO s) -> s -> RawFilePath -> IO s
  89. traverseDirectory act s0 topdir = toploop
  90. where
  91. toploop = do
  92. isDir <- isDirectory <$> getFileStatus topdir
  93. s' <- act s0 topdir
  94. if isDir then actOnDirContents topdir s' loop
  95. else return s'
  96. loop typ path acc = do
  97. isDir <- case () of
  98. () | typ == dtDir -> return True
  99. | typ == dtUnknown -> isDirectory <$> getFileStatus path
  100. | otherwise -> return False
  101. if isDir
  102. then act acc path >>= \acc' -> actOnDirContents path acc' loop
  103. else act acc path
  104. actOnDirContents :: RawFilePath
  105. -> b
  106. -> (DirType -> RawFilePath -> b -> IO b)
  107. -> IO b
  108. actOnDirContents pathRelToTop b f =
  109. modifyIOError ((`ioeSetFileName` (BS.unpack pathRelToTop)) .
  110. (`ioeSetLocation` "findBSTypRel")) $
  111. bracket
  112. (openDirStream pathRelToTop)
  113. Posix.closeDirStream
  114. (\dirp -> loop dirp b)
  115. where
  116. loop dirp b' = do
  117. (typ,e) <- readDirEnt dirp
  118. if (e == "")
  119. then return b'
  120. else
  121. if (e == "." || e == "..")
  122. then loop dirp b'
  123. else f typ (pathRelToTop </> e) b' >>= loop dirp
  124. ----------------------------------------------------------
  125. -- dodgy stuff
  126. type CDir = ()
  127. type CDirent = ()
  128. -- Posix doesn't export DirStream, so to re-use that type we need to use
  129. -- unsafeCoerce. It's just a newtype, so this is a legitimate usage.
  130. -- ugly trick.
  131. unpackDirStream :: DirStream -> Ptr CDir
  132. unpackDirStream = unsafeCoerce
  133. packDirStream :: Ptr CDir -> DirStream
  134. packDirStream = unsafeCoerce
  135. -- the __hscore_* functions are defined in the unix package. We can import them and let
  136. -- the linker figure it out.
  137. foreign import ccall unsafe "__hscore_readdir"
  138. c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
  139. foreign import ccall unsafe "__hscore_free_dirent"
  140. c_freeDirEnt :: Ptr CDirent -> IO ()
  141. foreign import ccall unsafe "__hscore_d_name"
  142. c_name :: Ptr CDirent -> IO CString
  143. foreign import ccall unsafe "__posixdir_d_type"
  144. c_type :: Ptr CDirent -> IO DirType
  145. foreign import ccall "realpath"
  146. c_realpath :: CString -> CString -> IO CString
  147. foreign import ccall unsafe "fdopendir"
  148. c_fdopendir :: Posix.Fd -> IO (Ptr ())
  149. ----------------------------------------------------------
  150. -- less dodgy but still lower-level
  151. readDirEnt :: DirStream -> IO (DirType, RawFilePath)
  152. readDirEnt (unpackDirStream -> dirp) =
  153. alloca $ \ptr_dEnt -> loop ptr_dEnt
  154. where
  155. loop ptr_dEnt = do
  156. resetErrno
  157. r <- c_readdir dirp ptr_dEnt
  158. if (r == 0)
  159. then do
  160. dEnt <- peek ptr_dEnt
  161. if (dEnt == nullPtr)
  162. then return (dtUnknown,BS.empty)
  163. else do
  164. dName <- c_name dEnt >>= peekFilePath
  165. dType <- c_type dEnt
  166. c_freeDirEnt dEnt
  167. return (dType, dName)
  168. else do
  169. errno <- getErrno
  170. if (errno == eINTR)
  171. then loop ptr_dEnt
  172. else do
  173. let (Errno eo) = errno
  174. if (eo == 0)
  175. then return (dtUnknown,BS.empty)
  176. else throwErrno "readDirEnt"
  177. -- |Gets all directory contents (not recursively).
  178. getDirectoryContents :: RawFilePath -> IO [(DirType, RawFilePath)]
  179. getDirectoryContents path =
  180. modifyIOError ((`ioeSetFileName` (BS.unpack path)) .
  181. (`ioeSetLocation` "System.Posix.RawFilePath.Directory.Traversals.getDirectoryContents")) $
  182. bracket
  183. (PosixBS.openDirStream path)
  184. PosixBS.closeDirStream
  185. _dirloop
  186. -- |Binding to @fdopendir(3)@.
  187. fdOpendir :: Posix.Fd -> IO DirStream
  188. fdOpendir fd =
  189. packDirStream <$> throwErrnoIfNull "fdOpendir" (c_fdopendir fd)
  190. -- |Like `getDirectoryContents` except for a file descriptor.
  191. --
  192. -- To avoid complicated error checks, the file descriptor is
  193. -- __always__ closed, even if `fdOpendir` fails. Usually, this
  194. -- only happens on successful `fdOpendir` and after the directory
  195. -- stream is closed. Also see the manpage of @fdopendir(3)@ for
  196. -- more details.
  197. getDirectoryContents' :: Posix.Fd -> IO [(DirType, RawFilePath)]
  198. getDirectoryContents' fd = do
  199. dirstream <- fdOpendir fd `catchIOError` \e -> do
  200. closeFd fd
  201. ioError e
  202. -- closeDirStream closes the filedescriptor
  203. finally (_dirloop dirstream) (PosixBS.closeDirStream dirstream)
  204. _dirloop :: DirStream -> IO [(DirType, RawFilePath)]
  205. {-# INLINE _dirloop #-}
  206. _dirloop dirp = do
  207. t@(_typ,e) <- readDirEnt dirp
  208. if BS.null e then return [] else do
  209. es <- _dirloop dirp
  210. return (t:es)
  211. -- | return the canonicalized absolute pathname
  212. --
  213. -- like canonicalizePath, but uses @realpath(3)@
  214. realpath :: RawFilePath -> IO RawFilePath
  215. realpath inp =
  216. allocaBytes pathMax $ \tmp -> do
  217. void $ BS.useAsCString inp $ \cstr -> throwErrnoIfNull "realpath" $ c_realpath cstr tmp
  218. BS.packCString tmp