{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UnboxedTuples #-}
#ifndef mingw32_HOST_OS
# if MIN_VERSION_unix(2, 8, 6) && __GLASGOW_HASKELL__ >= 902
# define HAVE_UNIX_CACHE 1
# endif
#endif
module System.Directory.OsPath.Streaming.Internal.Raw
( RawDirStream(..)
, openRawDirStream
, readRawDirStream
, closeRawDirStream
, DirReadCache(..)
, allocateDirReadCache
, releaseDirReadCache
, readRawDirStreamWithCache
) where
import System.OsPath (osp, (</>))
import System.Directory.OsPath.FileType
import System.Directory.OsPath.Types
#ifdef mingw32_HOST_OS
import Control.Concurrent.Counter (Counter)
import qualified Control.Concurrent.Counter as Counter
import Control.Monad (unless)
import System.OsPath.Types (OsPath)
import System.OsString.Internal.Types (OsString(OsString), getOsString)
import System.OsString.Windows (pstr)
import qualified System.Win32.Types as Win32
import qualified System.Win32.WindowsString.File as Win32
#endif
#ifndef mingw32_HOST_OS
import System.OsPath.Types (OsPath)
import System.OsString.Internal.Types (OsString(OsString), getOsString)
import qualified System.Posix.Directory.PosixPath as Posix
# ifdef HAVE_UNIX_CACHE
import Data.Coerce (coerce)
import Foreign.C (CString, CChar)
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.Storable (sizeOf, alignment, peekElemOff)
import qualified System.Posix.Directory.Internals as DirInternals
import System.Posix.PosixPath.FilePath (peekFilePath)
import GHC.Exts (MutableByteArray#, newAlignedPinnedByteArray#, mutableByteArrayContents#, RealWorld)
import GHC.IO (IO(..))
import GHC.Int (Int(..))
import GHC.Ptr (Ptr(..))
import System.Directory.OsPath.Utils (touch)
# endif
#endif
#ifdef mingw32_HOST_OS
data RawDirStream = RawDirStream !Win32.HANDLE !Win32.FindData !Counter !OsPath
#endif
#ifndef mingw32_HOST_OS
data RawDirStream = RawDirStream !Posix.DirStream !OsPath
#endif
openRawDirStream :: OsPath -> IO RawDirStream
#ifdef mingw32_HOST_OS
openRawDirStream fp = do
(h, fdat) <- Win32.findFirstFile $ getOsString fp <> [pstr|\*|]
hasMore <- Counter.new 1
pure $! RawDirStream h fdat hasMore fp
#endif
#ifndef mingw32_HOST_OS
openRawDirStream :: OsPath -> IO RawDirStream
openRawDirStream OsPath
root = do
stream <- PosixPath -> IO DirStream
Posix.openDirStream (OsPath -> PosixPath
getOsString OsPath
root)
pure $ RawDirStream stream root
#endif
closeRawDirStream :: RawDirStream -> IO ()
#ifdef mingw32_HOST_OS
closeRawDirStream (RawDirStream h _ _ _) = Win32.findClose h
#endif
#ifndef mingw32_HOST_OS
closeRawDirStream :: RawDirStream -> IO ()
closeRawDirStream (RawDirStream DirStream
stream OsPath
_) = DirStream -> IO ()
Posix.closeDirStream DirStream
stream
#endif
readRawDirStream :: RawDirStream -> IO (Maybe (OsPath, FileType))
readRawDirStream :: RawDirStream -> IO (Maybe (OsPath, FileType))
readRawDirStream RawDirStream
stream = do
cache <- IO DirReadCache
allocateDirReadCache
res <- readRawDirStreamWithCache cache stream
releaseDirReadCache cache
pure $ (\(OsPath
_, Basename OsPath
x, FileType
typ) -> (OsPath
x, FileType
typ)) <$> res
#ifdef mingw32_HOST_OS
newtype DirReadCache = DirReadCache ()
#endif
#ifndef mingw32_HOST_OS
# ifndef HAVE_UNIX_CACHE
newtype DirReadCache = DirReadCache ()
# endif
# ifdef HAVE_UNIX_CACHE
data DirReadCache = DirReadCache (MutableByteArray# RealWorld)
# endif
#endif
allocateDirReadCache :: IO DirReadCache
#ifdef mingw32_HOST_OS
allocateDirReadCache = pure $ DirReadCache ()
#endif
#ifndef mingw32_HOST_OS
# ifndef HAVE_UNIX_CACHE
allocateDirReadCache = pure $ DirReadCache ()
# endif
# ifdef HAVE_UNIX_CACHE
allocateDirReadCache :: IO DirReadCache
allocateDirReadCache = (State# RealWorld -> (# State# RealWorld, DirReadCache #))
-> IO DirReadCache
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, DirReadCache #))
-> IO DirReadCache)
-> (State# RealWorld -> (# State# RealWorld, DirReadCache #))
-> IO DirReadCache
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s0 ->
case Int#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
size Int#
align State# RealWorld
s0 of
(# State# RealWorld
s1, MutableByteArray# RealWorld
mbarr# #) ->
(# State# RealWorld
s1, MutableByteArray# RealWorld -> DirReadCache
DirReadCache MutableByteArray# RealWorld
mbarr# #)
where
!(I# Int#
size) = Ptr DirEnt -> Int
forall a. Storable a => a -> Int
sizeOf (Ptr DirEnt
forall a. HasCallStack => a
undefined :: Ptr DirInternals.DirEnt)
!(I# Int#
align) = Ptr DirEnt -> Int
forall a. Storable a => a -> Int
alignment (Ptr DirEnt
forall a. HasCallStack => a
undefined :: Ptr DirInternals.DirEnt)
# endif
#endif
releaseDirReadCache :: DirReadCache -> IO ()
#ifdef mingw32_HOST_OS
releaseDirReadCache _ = pure ()
#endif
#ifndef mingw32_HOST_OS
# ifndef HAVE_UNIX_CACHE
releaseDirReadCache _ = pure ()
# endif
# ifdef HAVE_UNIX_CACHE
releaseDirReadCache :: DirReadCache -> IO ()
releaseDirReadCache = DirReadCache -> IO ()
forall x. x -> IO ()
touch
# endif
#endif
readRawDirStreamWithCache
:: DirReadCache
-> RawDirStream
-> IO (Maybe (OsPath, Basename OsPath, FileType))
#ifdef mingw32_HOST_OS
readRawDirStreamWithCache _ stream@(RawDirStream _ _ _ root) = do
traverse (\x -> let full = root </> x in (full, Basename x,) <$> getFileType full) =<< _readRawDirStreamSimple stream
#endif
#ifndef mingw32_HOST_OS
# ifndef HAVE_UNIX_CACHE
readRawDirStreamWithCache _ stream@(RawDirStream _ root) = do
traverse (\x -> let full = root </> x in (full, Basename x,) <$> getFileType full) =<< _readRawDirStreamSimple stream
# endif
# ifdef HAVE_UNIX_CACHE
readRawDirStreamWithCache :: DirReadCache
-> RawDirStream -> IO (Maybe (OsPath, Basename OsPath, FileType))
readRawDirStreamWithCache (DirReadCache MutableByteArray# RealWorld
barr#) (RawDirStream DirStream
stream OsPath
root) = IO (Maybe (OsPath, Basename OsPath, FileType))
go
where
cache :: Ptr DirInternals.DirEnt
cache :: Ptr DirEnt
cache = Addr# -> Ptr DirEnt
forall a. Addr# -> Ptr a
Ptr (MutableByteArray# RealWorld -> Addr#
forall d. MutableByteArray# d -> Addr#
mutableByteArrayContents# MutableByteArray# RealWorld
barr#)
shouldSkipDirEntry :: CString -> IO Bool
shouldSkipDirEntry :: CString -> IO Bool
shouldSkipDirEntry CString
ptr
| CString
ptr CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr = Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
shouldSkipDirEntry CString
ptr = do
(x1 :: CChar) <- CString -> Int -> IO CChar
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff CString
ptr Int
0
case x1 of
CChar
0 -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
CChar
46 -> do
(x2 :: CChar) <- CString -> Int -> IO CChar
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff CString
ptr Int
1
case x2 of
CChar
0 -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
CChar
46 -> do
(x3 :: CChar) <- CString -> Int -> IO CChar
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff CString
ptr Int
2
pure $! x3 == 0
CChar
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
CChar
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
go :: IO (Maybe (OsPath, Basename OsPath, FileType))
go :: IO (Maybe (OsPath, Basename OsPath, FileType))
go = do
x <- Ptr DirEnt
-> (DirEnt -> IO (Maybe (OsPath, Basename OsPath, FileType)))
-> DirStream
-> IO (Maybe (Maybe (OsPath, Basename OsPath, FileType)))
forall a.
Ptr DirEnt -> (DirEnt -> IO a) -> DirStream -> IO (Maybe a)
DirInternals.readDirStreamWithPtr
Ptr DirEnt
cache
(\DirEnt
dirEnt -> do
(namePtr :: CString) <- DirEnt -> IO CString
DirInternals.dirEntName DirEnt
dirEnt
shouldSkip <- shouldSkipDirEntry namePtr
if shouldSkip
then
pure Nothing
else do
!path <- peekFilePath namePtr
let fullPath = OsPath
root OsPath -> OsPath -> OsPath
</> PosixPath -> OsPath
forall a b. Coercible a b => a -> b
coerce PosixPath
path
!typ <- DirInternals.dirEntType dirEnt
typ' <- case typ of
DirType
DirInternals.UnknownType -> OsPath -> IO FileType
getFileType OsPath
fullPath
DirType
DirInternals.NamedPipeType -> FileType -> IO FileType
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileType
regularOther
DirType
DirInternals.CharacterDeviceType -> FileType -> IO FileType
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileType
regularOther
DirType
DirInternals.DirectoryType -> FileType -> IO FileType
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileType
regularDirectory
DirType
DirInternals.BlockDeviceType -> FileType -> IO FileType
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileType
regularOther
DirType
DirInternals.RegularFileType -> FileType -> IO FileType
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileType
regularFile
DirType
DirInternals.SymbolicLinkType -> OsPath -> IO FileType
getFileType OsPath
fullPath
DirType
DirInternals.SocketType -> FileType -> IO FileType
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileType
regularOther
DirType
DirInternals.WhiteoutType -> FileType -> IO FileType
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FileType
regularOther
DirType
_ -> OsPath -> IO FileType
getFileType OsPath
fullPath
pure (Just (fullPath, Basename $ coerce path, typ')))
DirStream
stream
case x of
Maybe (Maybe (OsPath, Basename OsPath, FileType))
Nothing -> Maybe (OsPath, Basename OsPath, FileType)
-> IO (Maybe (OsPath, Basename OsPath, FileType))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (OsPath, Basename OsPath, FileType)
forall a. Maybe a
Nothing
Just Maybe (OsPath, Basename OsPath, FileType)
Nothing -> IO (Maybe (OsPath, Basename OsPath, FileType))
go
Just res :: Maybe (OsPath, Basename OsPath, FileType)
res@(Just (OsPath, Basename OsPath, FileType)
_) -> Maybe (OsPath, Basename OsPath, FileType)
-> IO (Maybe (OsPath, Basename OsPath, FileType))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (OsPath, Basename OsPath, FileType)
res
# endif
#endif
_readRawDirStreamSimple :: RawDirStream -> IO (Maybe OsPath)
#ifdef mingw32_HOST_OS
_readRawDirStreamSimple (RawDirStream h fdat hasMore _) = go
where
go = do
hasMore' <- Counter.get hasMore
if hasMore' /= 0
then do
filename <- Win32.getFindDataFileName fdat
hasMore'' <- Win32.findNextFile h fdat
unless hasMore'' $
Counter.set hasMore 0
if filename == getOsString [osp|.|] || filename == getOsString [osp|..|]
then go
else pure $ Just $ OsString filename
else pure Nothing
#endif
#ifndef mingw32_HOST_OS
_readRawDirStreamSimple :: RawDirStream -> IO (Maybe OsPath)
_readRawDirStreamSimple (RawDirStream DirStream
stream OsPath
_) = IO (Maybe OsPath)
go
where
# ifndef HAVE_UNIX_CACHE
go = do
fp <- Posix.readDirStream stream
case () of
_ | fp == mempty
-> pure Nothing
| fp == getOsString [osp|.|] || fp == getOsString [osp|..|]
-> go
| otherwise
-> pure $ Just $ OsString fp
# endif
# ifdef HAVE_UNIX_CACHE
go :: IO (Maybe OsPath)
go = do
fp <- DirStream -> IO (Maybe PosixPath)
Posix.readDirStreamMaybe DirStream
stream
case fp of
Maybe PosixPath
Nothing -> Maybe OsPath -> IO (Maybe OsPath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe OsPath
forall a. Maybe a
Nothing
Just PosixPath
fp'
| PosixPath
fp' PosixPath -> PosixPath -> Bool
forall a. Eq a => a -> a -> Bool
== OsPath -> PosixPath
getOsString [osp|.|] Bool -> Bool -> Bool
|| PosixPath
fp' PosixPath -> PosixPath -> Bool
forall a. Eq a => a -> a -> Bool
== OsPath -> PosixPath
getOsString [osp|..|]
-> IO (Maybe OsPath)
go
| Bool
otherwise
-> Maybe OsPath -> IO (Maybe OsPath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe OsPath -> IO (Maybe OsPath))
-> Maybe OsPath -> IO (Maybe OsPath)
forall a b. (a -> b) -> a -> b
$ OsPath -> Maybe OsPath
forall a. a -> Maybe a
Just (OsPath -> Maybe OsPath) -> OsPath -> Maybe OsPath
forall a b. (a -> b) -> a -> b
$ PosixPath -> OsPath
OsString PosixPath
fp'
# endif
#endif