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

140 lines
4.3 KiB
Haskell

{-# LANGUAGE CApiFFI #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall #-}
module GHCup.Prelude.File.Posix.Traversals (
-- lower-level stuff
readDirEnt
, readDirEntPortable
, openDirStreamPortable
, closeDirStreamPortable
, unpackDirStream
, DirStreamPortable
) where
#include <limits.h>
#include <stdlib.h>
#include <dirent.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import GHCup.Prelude.File.Posix.Foreign
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
----------------------------------------------------------
-- dodgy stuff
data {-# CTYPE "DIR" #-} CDir
data {-# CTYPE "struct dirent" #-} CDirent
-- 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
foreign import capi unsafe "dirutils.h __posixdir_d_type"
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_BLK}, _) -> pure (dt, fp)
(DirType #{const DT_CHR}, _) -> pure (dt, fp)
(DirType #{const DT_DIR}, _) -> pure (dt, fp)
(DirType #{const DT_FIFO}, _) -> pure (dt, fp)
(DirType #{const DT_LNK}, _) -> pure (dt, fp)
(DirType #{const DT_REG}, _) -> pure (dt, fp)
(DirType #{const DT_SOCK}, _) -> pure (dt, fp)
(DirType #{const DT_UNKNOWN}, _) -> pure (dt, fp)
(_, _)
| 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}