ghcup-hs/lib/GHCup/Prelude/File/Posix/Traversals.hsc

133 lines
3.9 KiB
Plaintext
Raw Normal View History

2022-05-14 15:58:11 +00:00
{-# LANGUAGE CApiFFI #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall #-}
2022-05-21 20:54:18 +00:00
module GHCup.Prelude.File.Posix.Traversals (
2022-05-14 15:58:11 +00:00
-- lower-level stuff
readDirEnt
, readDirEntPortable
, openDirStreamPortable
, closeDirStreamPortable
2022-05-14 15:58:11 +00:00
, unpackDirStream
, DirStreamPortable
2022-05-14 15:58:11 +00:00
) where
#include <limits.h>
#include <stdlib.h>
#include <dirent.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
2022-05-14 15:58:11 +00:00
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
2022-05-21 20:54:18 +00:00
import GHCup.Prelude.File.Posix.Foreign
2022-05-14 15:58:11 +00:00
import Unsafe.Coerce (unsafeCoerce)
import Foreign.C.Error
import Foreign.C.String
import Foreign.C.Types
import Foreign.Ptr
import Foreign.Storable
import System.Posix
import Foreign (alloca)
import System.Posix.Internals (peekFilePath)
import System.FilePath
2022-05-14 15:58:11 +00:00
----------------------------------------------------------
-- dodgy stuff
2022-11-22 11:41:44 +00:00
data {-# CTYPE "DIR" #-} CDir
data {-# CTYPE "struct dirent" #-} CDirent
2022-05-14 15:58:11 +00:00
-- Posix doesn't export DirStream, so to re-use that type we need to use
-- unsafeCoerce. It's just a newtype, so this is a legitimate usage.
-- ugly trick.
unpackDirStream :: DirStream -> Ptr CDir
unpackDirStream = unsafeCoerce
-- the __hscore_* functions are defined in the unix package. We can import them and let
-- the linker figure it out.
foreign import ccall unsafe "__hscore_readdir"
c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
foreign import ccall unsafe "__hscore_free_dirent"
c_freeDirEnt :: Ptr CDirent -> IO ()
foreign import ccall unsafe "__hscore_d_name"
c_name :: Ptr CDirent -> IO CString
2022-11-22 11:41:44 +00:00
foreign import capi unsafe "dirutils.h __posixdir_d_type"
2022-05-14 15:58:11 +00:00
c_type :: Ptr CDirent -> IO DirType
----------------------------------------------------------
-- less dodgy but still lower-level
readDirEnt :: DirStream -> IO (DirType, FilePath)
readDirEnt (unpackDirStream -> dirp) =
alloca $ \ptr_dEnt -> loop ptr_dEnt
where
loop ptr_dEnt = do
resetErrno
r <- c_readdir dirp ptr_dEnt
if r == 0
then do
dEnt <- peek ptr_dEnt
if dEnt == nullPtr
then return (dtUnknown, mempty)
else do
dName <- c_name dEnt >>= peekFilePath
dType <- c_type dEnt
c_freeDirEnt dEnt
return (dType, dName)
else do
errno <- getErrno
if errno == eINTR
then loop ptr_dEnt
else do
let (Errno eo) = errno
if eo == 0
then return (dtUnknown, mempty)
else throwErrno "readDirEnt"
newtype DirStreamPortable = DirStreamPortable (FilePath, DirStream)
openDirStreamPortable :: FilePath -> IO DirStreamPortable
openDirStreamPortable fp = do
dirs <- openDirStream fp
pure $ DirStreamPortable (fp, dirs)
closeDirStreamPortable :: DirStreamPortable -> IO ()
closeDirStreamPortable (DirStreamPortable (_, dirs)) = closeDirStream dirs
readDirEntPortable :: DirStreamPortable -> IO (DirType, FilePath)
readDirEntPortable (DirStreamPortable (basedir, dirs)) = do
(dt, fp) <- readDirEnt dirs
case (dt, fp) of
(DirType #{const DT_UNKNOWN}, _)
| fp /= "" -> do
stat <- getSymbolicLinkStatus (basedir </> fp)
pure $ (, fp) $ if | isBlockDevice stat -> DirType #{const DT_BLK}
| isCharacterDevice stat -> DirType #{const DT_CHR}
| isDirectory stat -> DirType #{const DT_DIR}
| isNamedPipe stat -> DirType #{const DT_FIFO}
| isSymbolicLink stat -> DirType #{const DT_LNK}
| isRegularFile stat -> DirType #{const DT_REG}
| isSocket stat -> DirType #{const DT_SOCK}
| otherwise -> DirType #{const DT_UNKNOWN}
_ -> pure (dt, fp)