{-# LINE 1 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
{-# LANGUAGE CPP #-}
module System.Directory.Internal.Windows where


{-# LINE 5 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
#if defined(i386_HOST_ARCH)
# define WINAPI stdcall
#elif defined(x86_64_HOST_ARCH)
# define WINAPI ccall
#else
# error unknown architecture
#endif




import Prelude ()
import System.Directory.Internal.Prelude
import System.Directory.Internal.Common
import System.Directory.Internal.Config (exeExtension)
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)

{-# LINE 25 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
import System.OsPath
  ( (</>)
  , isPathSeparator
  , isRelative
  , pack
  , pathSeparator
  , splitDirectories
  , takeExtension
  , toChar
  , unpack
  )
import System.OsPath.Types (WindowsPath, WindowsString)
import System.OsString.Internal.Types (OsString(OsString, getOsString))
import qualified Data.List as List
import qualified System.Win32.WindowsString.File as Win32
import qualified System.Win32.WindowsString.Info as Win32
import qualified System.Win32.WindowsString.Shell as Win32
import qualified System.Win32.WindowsString.Time as Win32
import qualified System.Win32.WindowsString.Types as Win32

type RawHandle = OsPath

pathAt :: Maybe RawHandle -> OsPath -> OsPath
pathAt :: Maybe OsPath -> OsPath -> OsPath
pathAt Maybe OsPath
dir OsPath
path = OsPath -> Maybe OsPath -> OsPath
forall a. a -> Maybe a -> a
fromMaybe OsPath
forall a. Monoid a => a
mempty Maybe OsPath
dir OsPath -> OsPath -> OsPath
</> OsPath
path

openRaw :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO RawHandle
openRaw :: WhetherFollow -> Maybe OsPath -> OsPath -> IO OsPath
openRaw WhetherFollow
_ Maybe OsPath
dir OsPath
path = OsPath -> IO OsPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe OsPath -> OsPath -> OsPath
pathAt Maybe OsPath
dir OsPath
path)

closeRaw :: RawHandle -> IO ()
closeRaw :: OsPath -> IO ()
closeRaw OsPath
_ = () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

createDirectoryInternal :: OsPath -> IO ()
createDirectoryInternal :: OsPath -> IO ()
createDirectoryInternal OsPath
path =
  (IOError -> OsPath -> IOError
`ioeSetOsPath` OsPath
path) (IOError -> IOError) -> IO () -> IO ()
forall a. (IOError -> IOError) -> IO a -> IO a
`modifyIOError` do
    path' <- OsPath -> IO WindowsPath
furnishPath OsPath
path
    Win32.createDirectory path' Nothing

removePathAt :: FileType -> Maybe RawHandle -> OsPath -> IO ()
removePathAt :: FileType -> Maybe OsPath -> OsPath -> IO ()
removePathAt FileType
ty Maybe OsPath
dir OsPath
path = Bool -> OsPath -> IO ()
removePathInternal Bool
isDir (Maybe OsPath -> OsPath -> OsPath
pathAt Maybe OsPath
dir OsPath
path)
  where isDir :: Bool
isDir = FileType -> Bool
fileTypeIsDirectory FileType
ty

removePathInternal :: Bool -> OsPath -> IO ()
removePathInternal :: Bool -> OsPath -> IO ()
removePathInternal Bool
isDir OsPath
path =
  (IOError -> OsPath -> IOError
`ioeSetOsPath` OsPath
path) (IOError -> IOError) -> IO () -> IO ()
forall a. (IOError -> IOError) -> IO a -> IO a
`modifyIOError` do
    OsPath -> IO WindowsPath
furnishPath OsPath
path
      IO WindowsPath -> (WindowsPath -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= if Bool
isDir then WindowsPath -> IO ()
Win32.removeDirectory else WindowsPath -> IO ()
Win32.deleteFile

renamePathInternal :: OsPath -> OsPath -> IO ()
renamePathInternal :: OsPath -> OsPath -> IO ()
renamePathInternal OsPath
opath OsPath
npath =
  (IOError -> OsPath -> IOError
`ioeSetOsPath` OsPath
opath) (IOError -> IOError) -> IO () -> IO ()
forall a. (IOError -> IOError) -> IO a -> IO a
`modifyIOError` do
    opath' <- OsPath -> IO WindowsPath
furnishPath OsPath
opath
    npath' <- furnishPath npath
    Win32.moveFileEx opath' (Just npath') Win32.mOVEFILE_REPLACE_EXISTING

-- On Windows, the removability of a file may be affected by the attributes of

-- the file itself.

filesAlwaysRemovable :: Bool
filesAlwaysRemovable :: Bool
filesAlwaysRemovable = Bool
False

copyFileWithMetadataInternal :: (Metadata -> OsPath -> IO ())
                             -> (Metadata -> OsPath -> IO ())
                             -> OsPath
                             -> OsPath
                             -> IO ()
copyFileWithMetadataInternal :: (Metadata -> OsPath -> IO ())
-> (Metadata -> OsPath -> IO ()) -> OsPath -> OsPath -> IO ()
copyFileWithMetadataInternal Metadata -> OsPath -> IO ()
_ Metadata -> OsPath -> IO ()
_ OsPath
src OsPath
dst =
  (IOError -> OsPath -> IOError
`ioeSetOsPath` OsPath
src) (IOError -> IOError) -> IO () -> IO ()
forall a. (IOError -> IOError) -> IO a -> IO a
`modifyIOError` do
    src' <- OsPath -> IO WindowsPath
furnishPath OsPath
src
    dst' <- furnishPath dst
    Win32.copyFile src' dst' False

win32_cSIDL_COMMON_APPDATA :: Win32.CSIDL
win32_cSIDL_COMMON_APPDATA :: CSIDL
win32_cSIDL_COMMON_APPDATA = (CSIDL
35)
{-# LINE 97 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}

win32_eRROR_ENVVAR_NOT_FOUND :: Win32.ErrCode
win32_eRROR_ENVVAR_NOT_FOUND :: SHGetFolderPathFlags
win32_eRROR_ENVVAR_NOT_FOUND = (SHGetFolderPathFlags
203)
{-# LINE 100 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}

win32_eRROR_INVALID_FUNCTION :: Win32.ErrCode
win32_eRROR_INVALID_FUNCTION :: SHGetFolderPathFlags
win32_eRROR_INVALID_FUNCTION = (SHGetFolderPathFlags
1)
{-# LINE 103 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}

win32_eRROR_INVALID_PARAMETER :: Win32.ErrCode
win32_eRROR_INVALID_PARAMETER :: SHGetFolderPathFlags
win32_eRROR_INVALID_PARAMETER = (SHGetFolderPathFlags
87)
{-# LINE 106 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}

win32_eRROR_PRIVILEGE_NOT_HELD :: Win32.ErrCode
win32_eRROR_PRIVILEGE_NOT_HELD :: SHGetFolderPathFlags
win32_eRROR_PRIVILEGE_NOT_HELD = (SHGetFolderPathFlags
1314)
{-# LINE 109 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}

win32_sYMBOLIC_LINK_FLAG_DIRECTORY :: Win32.DWORD
win32_sYMBOLIC_LINK_FLAG_DIRECTORY :: SHGetFolderPathFlags
win32_sYMBOLIC_LINK_FLAG_DIRECTORY = SHGetFolderPathFlags
0x1

win32_sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE :: Win32.DWORD
win32_sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE :: SHGetFolderPathFlags
win32_sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE = SHGetFolderPathFlags
0x2

maxShareMode :: Win32.ShareMode
maxShareMode :: SHGetFolderPathFlags
maxShareMode =
  SHGetFolderPathFlags
Win32.fILE_SHARE_DELETE SHGetFolderPathFlags
-> SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Bits a => a -> a -> a
.|.
  SHGetFolderPathFlags
Win32.fILE_SHARE_READ   SHGetFolderPathFlags
-> SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Bits a => a -> a -> a
.|.
  SHGetFolderPathFlags
Win32.fILE_SHARE_WRITE

win32_getFinalPathNameByHandle :: Win32.HANDLE -> Win32.DWORD -> IO WindowsPath

{-# LINE 124 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
win32_getFinalPathNameByHandle h flags = do
  result <- peekTStringWith (260) $ \ ptr len -> do
{-# LINE 126 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
    c_GetFinalPathNameByHandle h ptr len flags
  case result of
    Left errCode -> Win32.failWith "GetFinalPathNameByHandle" errCode
    Right path -> pure path

foreign import WINAPI unsafe "windows.h GetFinalPathNameByHandleW"
  c_GetFinalPathNameByHandle
    :: Win32.HANDLE
    -> Ptr CWchar
    -> Win32.DWORD
    -> Win32.DWORD
    -> IO Win32.DWORD


{-# LINE 147 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}

getFinalPathName :: OsPath -> IO OsPath
getFinalPathName :: OsPath -> IO OsPath
getFinalPathName =
  (WindowsPath -> OsPath
fromExtendedLengthPath (WindowsPath -> OsPath) -> IO WindowsPath -> IO OsPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (IO WindowsPath -> IO OsPath)
-> (OsPath -> IO WindowsPath) -> OsPath -> IO OsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  WindowsPath -> IO WindowsPath
rawGetFinalPathName (WindowsPath -> IO WindowsPath)
-> (OsPath -> WindowsPath) -> OsPath -> IO WindowsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  OsPath -> WindowsPath
toExtendedLengthPath
  where

{-# LINE 155 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
    rawGetFinalPathName path = do
      let open = Win32.createFile path 0 maxShareMode Nothing
                 Win32.oPEN_EXISTING Win32.fILE_FLAG_BACKUP_SEMANTICS Nothing
      bracket open Win32.closeHandle $ \ h -> do
        win32_getFinalPathNameByHandle h 0

{-# LINE 163 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}

win32_fILE_FLAG_OPEN_REPARSE_POINT :: Win32.FileAttributeOrFlag
win32_fILE_FLAG_OPEN_REPARSE_POINT :: SHGetFolderPathFlags
win32_fILE_FLAG_OPEN_REPARSE_POINT = SHGetFolderPathFlags
0x00200000

win32_fSCTL_GET_REPARSE_POINT :: Win32.DWORD
win32_fSCTL_GET_REPARSE_POINT :: SHGetFolderPathFlags
win32_fSCTL_GET_REPARSE_POINT = SHGetFolderPathFlags
0x900a8

win32_iO_REPARSE_TAG_MOUNT_POINT, win32_iO_REPARSE_TAG_SYMLINK :: CULong
win32_iO_REPARSE_TAG_MOUNT_POINT :: CULong
win32_iO_REPARSE_TAG_MOUNT_POINT = (CULong
2684354563)
{-# LINE 172 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
win32_iO_REPARSE_TAG_SYMLINK = (2684354572)
{-# LINE 173 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}

win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE :: Win32.DWORD
win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE :: SHGetFolderPathFlags
win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE =
  (SHGetFolderPathFlags
16384)
{-# LINE 177 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}

win32_sYMLINK_FLAG_RELATIVE :: CULong
win32_sYMLINK_FLAG_RELATIVE :: CULong
win32_sYMLINK_FLAG_RELATIVE = CULong
0x00000001

data Win32_REPARSE_DATA_BUFFER
  = Win32_MOUNT_POINT_REPARSE_DATA_BUFFER WindowsString WindowsString
    -- ^ substituteName printName

  | Win32_SYMLINK_REPARSE_DATA_BUFFER WindowsString WindowsString Bool
    -- ^ substituteName printName isRelative

  | Win32_GENERIC_REPARSE_DATA_BUFFER

win32_alloca_REPARSE_DATA_BUFFER
  :: ((Ptr Win32_REPARSE_DATA_BUFFER, Int) -> IO a) -> IO a
win32_alloca_REPARSE_DATA_BUFFER :: forall a. ((Ptr Win32_REPARSE_DATA_BUFFER, Int) -> IO a) -> IO a
win32_alloca_REPARSE_DATA_BUFFER (Ptr Win32_REPARSE_DATA_BUFFER, Int) -> IO a
action =
  Int -> Int -> (Ptr Win32_REPARSE_DATA_BUFFER -> IO a) -> IO a
forall a b. Int -> Int -> (Ptr a -> IO b) -> IO b
allocaBytesAligned Int
size Int
align ((Ptr Win32_REPARSE_DATA_BUFFER -> IO a) -> IO a)
-> (Ptr Win32_REPARSE_DATA_BUFFER -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \ Ptr Win32_REPARSE_DATA_BUFFER
ptr ->
    (Ptr Win32_REPARSE_DATA_BUFFER, Int) -> IO a
action (Ptr Win32_REPARSE_DATA_BUFFER
ptr, Int
size)
  where size :: Int
size = SHGetFolderPathFlags -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral SHGetFolderPathFlags
win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE
        align :: Int
align = Int
4
{-# LINE 195 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}

win32_peek_REPARSE_DATA_BUFFER
  :: Ptr Win32_REPARSE_DATA_BUFFER -> IO Win32_REPARSE_DATA_BUFFER
win32_peek_REPARSE_DATA_BUFFER :: Ptr Win32_REPARSE_DATA_BUFFER -> IO Win32_REPARSE_DATA_BUFFER
win32_peek_REPARSE_DATA_BUFFER Ptr Win32_REPARSE_DATA_BUFFER
p = do
  tag <- (\Ptr Win32_REPARSE_DATA_BUFFER
hsc_ptr -> Ptr Win32_REPARSE_DATA_BUFFER -> Int -> IO CULong
forall b. Ptr b -> Int -> IO CULong
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Win32_REPARSE_DATA_BUFFER
hsc_ptr Int
0) Ptr Win32_REPARSE_DATA_BUFFER
p
{-# LINE 200 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
  case () of
    _ | tag == win32_iO_REPARSE_TAG_MOUNT_POINT -> do
          let buf = (\hsc_ptr -> hsc_ptr `plusPtr` 16) p
{-# LINE 204 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          sni <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p
{-# LINE 206 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          sns <- (\hsc_ptr -> peekByteOff hsc_ptr 10) p
{-# LINE 208 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          sn <- peekName buf sni sns
          pni <- (\hsc_ptr -> peekByteOff hsc_ptr 12) p
{-# LINE 211 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          pns <- (\hsc_ptr -> peekByteOff hsc_ptr 14) p
{-# LINE 213 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          pn <- peekName buf pni pns
          pure (Win32_MOUNT_POINT_REPARSE_DATA_BUFFER sn pn)
      | tag == win32_iO_REPARSE_TAG_SYMLINK -> do
          let buf = (\hsc_ptr -> hsc_ptr `plusPtr` 20) p
{-# LINE 218 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          sni <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p
{-# LINE 220 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          sns <- (\hsc_ptr -> peekByteOff hsc_ptr 10) p
{-# LINE 222 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          sn <- peekName buf sni sns
          pni <- (\hsc_ptr -> peekByteOff hsc_ptr 12) p
{-# LINE 225 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          pns <- (\hsc_ptr -> peekByteOff hsc_ptr 14) p
{-# LINE 227 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          pn <- peekName buf pni pns
          flags <- (\hsc_ptr -> peekByteOff hsc_ptr 16) p
{-# LINE 230 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          pure (Win32_SYMLINK_REPARSE_DATA_BUFFER sn pn
                (flags .&. win32_sYMLINK_FLAG_RELATIVE /= 0))
      | otherwise -> pure Win32_GENERIC_REPARSE_DATA_BUFFER
  where
    peekName :: Ptr CWchar -> CUShort -> CUShort -> IO WindowsString
    peekName :: LPTSTR -> CUShort -> CUShort -> IO WindowsPath
peekName LPTSTR
buf CUShort
offset CUShort
size =
      (LPTSTR, Int) -> IO WindowsPath
Win32.peekTStringLen ( LPTSTR
buf LPTSTR -> Int -> LPTSTR
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` CUShort -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUShort
offset
                           , CUShort -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CUShort
size Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` TCHAR -> Int
forall a. Storable a => a -> Int
sizeOf (TCHAR
0 :: CWchar) )

deviceIoControl
  :: Win32.HANDLE
  -> Win32.DWORD
  -> (Ptr a, Int)
  -> (Ptr b, Int)
  -> Maybe Void
  -> IO (Either Win32.ErrCode Int)
deviceIoControl :: forall a b.
HANDLE
-> SHGetFolderPathFlags
-> (Ptr a, Int)
-> (Ptr b, Int)
-> Maybe Void
-> IO (Either SHGetFolderPathFlags Int)
deviceIoControl HANDLE
h SHGetFolderPathFlags
code (Ptr a
inPtr, Int
inSize) (Ptr b
outPtr, Int
outSize) Maybe Void
_ = do
  SHGetFolderPathFlags
-> (Ptr SHGetFolderPathFlags
    -> IO (Either SHGetFolderPathFlags Int))
-> IO (Either SHGetFolderPathFlags Int)
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with SHGetFolderPathFlags
0 ((Ptr SHGetFolderPathFlags -> IO (Either SHGetFolderPathFlags Int))
 -> IO (Either SHGetFolderPathFlags Int))
-> (Ptr SHGetFolderPathFlags
    -> IO (Either SHGetFolderPathFlags Int))
-> IO (Either SHGetFolderPathFlags Int)
forall a b. (a -> b) -> a -> b
$ \ Ptr SHGetFolderPathFlags
lenPtr -> do
    ok <- HANDLE
-> SHGetFolderPathFlags
-> Ptr a
-> SHGetFolderPathFlags
-> Ptr b
-> SHGetFolderPathFlags
-> Ptr SHGetFolderPathFlags
-> Ptr Void
-> IO Bool
forall a b.
HANDLE
-> SHGetFolderPathFlags
-> Ptr a
-> SHGetFolderPathFlags
-> Ptr b
-> SHGetFolderPathFlags
-> Ptr SHGetFolderPathFlags
-> Ptr Void
-> IO Bool
c_DeviceIoControl HANDLE
h SHGetFolderPathFlags
code Ptr a
inPtr (Int -> SHGetFolderPathFlags
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
inSize) Ptr b
outPtr
                            (Int -> SHGetFolderPathFlags
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
outSize) Ptr SHGetFolderPathFlags
lenPtr Ptr Void
forall {b}. Ptr b
nullPtr
    if ok
      then Right . fromIntegral <$> peek lenPtr
      else Left <$> Win32.getLastError

foreign import WINAPI unsafe "windows.h DeviceIoControl"
  c_DeviceIoControl
    :: Win32.HANDLE
    -> Win32.DWORD
    -> Ptr a
    -> Win32.DWORD
    -> Ptr b
    -> Win32.DWORD
    -> Ptr Win32.DWORD
    -> Ptr Void
    -> IO Win32.BOOL

readSymbolicLink :: OsPath -> IO OsPath
readSymbolicLink :: OsPath -> IO OsPath
readSymbolicLink OsPath
path =
  (IOError -> OsPath -> IOError
`ioeSetOsPath` OsPath
path) (IOError -> IOError) -> IO OsPath -> IO OsPath
forall a. (IOError -> IOError) -> IO a -> IO a
`modifyIOError` do
    path' <- OsPath -> IO WindowsPath
furnishPath OsPath
path
    let open = WindowsPath
-> SHGetFolderPathFlags
-> SHGetFolderPathFlags
-> Maybe LPSECURITY_ATTRIBUTES
-> SHGetFolderPathFlags
-> SHGetFolderPathFlags
-> Maybe HANDLE
-> IO HANDLE
Win32.createFile WindowsPath
path' SHGetFolderPathFlags
0 SHGetFolderPathFlags
maxShareMode Maybe LPSECURITY_ATTRIBUTES
forall a. Maybe a
Nothing SHGetFolderPathFlags
Win32.oPEN_EXISTING
                                (SHGetFolderPathFlags
Win32.fILE_FLAG_BACKUP_SEMANTICS SHGetFolderPathFlags
-> SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Bits a => a -> a -> a
.|.
                                SHGetFolderPathFlags
win32_fILE_FLAG_OPEN_REPARSE_POINT) Maybe HANDLE
forall a. Maybe a
Nothing
    bracket open Win32.closeHandle $ \ HANDLE
h -> do
      ((Ptr Win32_REPARSE_DATA_BUFFER, Int) -> IO OsPath) -> IO OsPath
forall a. ((Ptr Win32_REPARSE_DATA_BUFFER, Int) -> IO a) -> IO a
win32_alloca_REPARSE_DATA_BUFFER (((Ptr Win32_REPARSE_DATA_BUFFER, Int) -> IO OsPath) -> IO OsPath)
-> ((Ptr Win32_REPARSE_DATA_BUFFER, Int) -> IO OsPath) -> IO OsPath
forall a b. (a -> b) -> a -> b
$ \ ptrAndSize :: (Ptr Win32_REPARSE_DATA_BUFFER, Int)
ptrAndSize@(Ptr Win32_REPARSE_DATA_BUFFER
ptr, Int
_) -> do
        result <- HANDLE
-> SHGetFolderPathFlags
-> (Ptr (ZonkAny 0), Int)
-> (Ptr Win32_REPARSE_DATA_BUFFER, Int)
-> Maybe Void
-> IO (Either SHGetFolderPathFlags Int)
forall a b.
HANDLE
-> SHGetFolderPathFlags
-> (Ptr a, Int)
-> (Ptr b, Int)
-> Maybe Void
-> IO (Either SHGetFolderPathFlags Int)
deviceIoControl HANDLE
h SHGetFolderPathFlags
win32_fSCTL_GET_REPARSE_POINT
                                  (Ptr (ZonkAny 0)
forall {b}. Ptr b
nullPtr, Int
0) (Ptr Win32_REPARSE_DATA_BUFFER, Int)
ptrAndSize Maybe Void
forall a. Maybe a
Nothing
        case result of
          Left SHGetFolderPathFlags
e | SHGetFolderPathFlags
e SHGetFolderPathFlags -> SHGetFolderPathFlags -> Bool
forall a. Eq a => a -> a -> Bool
== SHGetFolderPathFlags
win32_eRROR_INVALID_FUNCTION -> do
                     let msg :: [Char]
msg = [Char]
"Incorrect function. The file system " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
                               [Char]
"might not support symbolic links."
                     IOError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (IOErrorType -> [Char] -> Maybe Handle -> Maybe [Char] -> IOError
mkIOError IOErrorType
illegalOperationErrorType
                                        [Char]
"DeviceIoControl" Maybe Handle
forall a. Maybe a
Nothing Maybe [Char]
forall a. Maybe a
Nothing
                              IOError -> [Char] -> IOError
`ioeSetErrorString` [Char]
msg)
                 | Bool
otherwise -> [Char] -> SHGetFolderPathFlags -> IO ()
forall a. [Char] -> SHGetFolderPathFlags -> IO a
Win32.failWith [Char]
"DeviceIoControl" SHGetFolderPathFlags
e
          Right Int
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        rData <- win32_peek_REPARSE_DATA_BUFFER ptr
        strip . OsString <$> case rData of
          Win32_MOUNT_POINT_REPARSE_DATA_BUFFER WindowsPath
sn WindowsPath
_ -> WindowsPath -> IO WindowsPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WindowsPath
sn
          Win32_SYMLINK_REPARSE_DATA_BUFFER WindowsPath
sn WindowsPath
_ Bool
_ -> WindowsPath -> IO WindowsPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WindowsPath
sn
          Win32_REPARSE_DATA_BUFFER
_ -> IOError -> IO WindowsPath
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (IOErrorType -> [Char] -> Maybe Handle -> Maybe [Char] -> IOError
mkIOError IOErrorType
InappropriateType
                                  [Char]
"readSymbolicLink" Maybe Handle
forall a. Maybe a
Nothing Maybe [Char]
forall a. Maybe a
Nothing)
  where
    strip :: OsPath -> OsPath
strip OsPath
sn =
      OsPath -> Maybe OsPath -> OsPath
forall a. a -> Maybe a -> a
fromMaybe OsPath
sn
        ([OsChar] -> OsPath
pack ([OsChar] -> OsPath) -> Maybe [OsChar] -> Maybe OsPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OsChar] -> [OsChar] -> Maybe [OsChar]
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix (OsPath -> [OsChar]
unpack ([Char] -> OsPath
os [Char]
"\\??\\")) (OsPath -> [OsChar]
unpack OsPath
sn))

-- | On Windows, equivalent to 'simplifyWindows'.

simplify :: OsPath -> OsPath
simplify :: OsPath -> OsPath
simplify = OsPath -> OsPath
simplifyWindows

-- | Normalise the path separators and prepend the @"\\\\?\\"@ prefix if

-- necessary or possible.  This is used for symbolic links targets because

-- they can't handle forward slashes.

normaliseSeparators :: OsPath -> WindowsPath
normaliseSeparators :: OsPath -> WindowsPath
normaliseSeparators OsPath
path
  | OsPath -> Bool
isRelative OsPath
path = OsPath -> WindowsPath
getOsString ([OsChar] -> OsPath
pack (OsChar -> OsChar
normaliseSep (OsChar -> OsChar) -> [OsChar] -> [OsChar]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OsPath -> [OsChar]
unpack OsPath
path))
  | Bool
otherwise = OsPath -> WindowsPath
toExtendedLengthPath OsPath
path
  where normaliseSep :: OsChar -> OsChar
normaliseSep OsChar
c = if OsChar -> Bool
isPathSeparator OsChar
c then OsChar
pathSeparator else OsChar
c

-- | 'simplify' the path and prepend the @"\\\\?\\"@ if possible.  This

-- function can sometimes be used to bypass the @MAX_PATH@ length restriction

-- in Windows API calls.

toExtendedLengthPath :: OsPath -> WindowsPath
toExtendedLengthPath :: OsPath -> WindowsPath
toExtendedLengthPath OsPath
path =
  OsPath -> WindowsPath
getOsString (OsPath -> WindowsPath) -> OsPath -> WindowsPath
forall a b. (a -> b) -> a -> b
$
  if OsPath -> Bool
isRelative OsPath
path
  then OsPath
simplifiedPath
  else
    case OsChar -> Char
toChar (OsChar -> Char) -> [OsChar] -> [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OsChar]
simplifiedPath' of
      Char
'\\' : Char
'?'  : Char
'?' : Char
'\\' : [Char]
_ -> OsPath
simplifiedPath
      Char
'\\' : Char
'\\' : Char
'?' : Char
'\\' : [Char]
_ -> OsPath
simplifiedPath
      Char
'\\' : Char
'\\' : Char
'.' : Char
'\\' : [Char]
_ -> OsPath
simplifiedPath
      Char
'\\' : Char
'\\' : [Char]
_ ->
        [Char] -> OsPath
os [Char]
"\\\\?\\UNC" OsPath -> OsPath -> OsPath
forall a. Semigroup a => a -> a -> a
<> [OsChar] -> OsPath
pack (Int -> [OsChar] -> [OsChar]
forall a. Int -> [a] -> [a]
drop Int
1 [OsChar]
simplifiedPath')
      [Char]
_ -> [Char] -> OsPath
os [Char]
"\\\\?\\" OsPath -> OsPath -> OsPath
forall a. Semigroup a => a -> a -> a
<> OsPath
simplifiedPath
  where simplifiedPath :: OsPath
simplifiedPath = OsPath -> OsPath
simplify OsPath
path
        simplifiedPath' :: [OsChar]
simplifiedPath' = OsPath -> [OsChar]
unpack OsPath
simplifiedPath

-- | Make a path absolute and convert to an extended length path, if possible.

--

-- Empty paths are left unchanged.

--

-- This function never fails.  If it doesn't understand the path, it just

-- returns the path unchanged.

furnishPath :: OsPath -> IO WindowsPath
furnishPath :: OsPath -> IO WindowsPath
furnishPath OsPath
path =
  (OsPath -> WindowsPath
toExtendedLengthPath (OsPath -> WindowsPath) -> IO OsPath -> IO WindowsPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OsPath -> IO OsPath
rawPrependCurrentDirectory OsPath
path)
    IO WindowsPath -> (IOError -> IO WindowsPath) -> IO WindowsPath
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \ IOError
_ ->
      WindowsPath -> IO WindowsPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OsPath -> WindowsPath
getOsString OsPath
path)

-- | Strip the @"\\\\?\\"@ prefix if possible.

-- The prefix is kept if the meaning of the path would otherwise change.

fromExtendedLengthPath :: WindowsPath -> OsPath
fromExtendedLengthPath :: WindowsPath -> OsPath
fromExtendedLengthPath WindowsPath
ePath' =
  case OsPath -> [OsChar]
unpack OsPath
ePath of
    OsChar
c1 : OsChar
c2 : OsChar
c3 : OsChar
c4 : [OsChar]
path
      | (OsChar -> Char
toChar (OsChar -> Char) -> [OsChar] -> [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OsChar
c1, OsChar
c2, OsChar
c3, OsChar
c4]) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"\\\\?\\" ->
      case [OsChar]
path of
        OsChar
c5 : OsChar
c6 : OsChar
c7 : subpath :: [OsChar]
subpath@(OsChar
c8 : [OsChar]
_)
          | (OsChar -> Char
toChar (OsChar -> Char) -> [OsChar] -> [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OsChar
c5, OsChar
c6, OsChar
c7, OsChar
c8]) [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"UNC\\" ->
            [OsChar] -> OsPath
pack (OsChar
c8 OsChar -> [OsChar] -> [OsChar]
forall a. a -> [a] -> [a]
: [OsChar]
subpath)
        OsChar
drive : OsChar
col : [OsChar]
subpath
          -- if the path is not "regular", then the prefix is necessary

          -- to ensure the path is interpreted literally

          | OsChar -> Char
toChar OsChar
col Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
':', OsChar -> Bool
isDriveChar OsChar
drive, [OsChar] -> Bool
isPathRegular [OsChar]
subpath ->
            [OsChar] -> OsPath
pack [OsChar]
path
        [OsChar]
_ -> OsPath
ePath
    [OsChar]
_ -> OsPath
ePath
  where
    ePath :: OsPath
ePath = WindowsPath -> OsPath
OsString WindowsPath
ePath'
    isDriveChar :: OsChar -> Bool
isDriveChar OsChar
drive = Char -> Bool
isAlpha (OsChar -> Char
toChar OsChar
drive) Bool -> Bool -> Bool
&& Char -> Bool
isAscii (OsChar -> Char
toChar OsChar
drive)
    isPathRegular :: [OsChar] -> Bool
isPathRegular [OsChar]
path =
      Bool -> Bool
not (Char
'/' Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (OsChar -> Char
toChar (OsChar -> Char) -> [OsChar] -> [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OsChar]
path) Bool -> Bool -> Bool
||
           [Char] -> OsPath
os [Char]
"." OsPath -> [OsPath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` OsPath -> [OsPath]
splitDirectories ([OsChar] -> OsPath
pack [OsChar]
path) Bool -> Bool -> Bool
||
           [Char] -> OsPath
os [Char]
".." OsPath -> [OsPath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` OsPath -> [OsPath]
splitDirectories ([OsChar] -> OsPath
pack [OsChar]
path))

saturatingDouble :: Win32.DWORD -> Win32.DWORD
saturatingDouble :: SHGetFolderPathFlags -> SHGetFolderPathFlags
saturatingDouble SHGetFolderPathFlags
s | SHGetFolderPathFlags
s SHGetFolderPathFlags -> SHGetFolderPathFlags -> Bool
forall a. Ord a => a -> a -> Bool
> SHGetFolderPathFlags
forall a. Bounded a => a
maxBound SHGetFolderPathFlags
-> SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Integral a => a -> a -> a
`div` SHGetFolderPathFlags
2 = SHGetFolderPathFlags
forall a. Bounded a => a
maxBound
                   | Bool
otherwise            = SHGetFolderPathFlags
s SHGetFolderPathFlags
-> SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Num a => a -> a -> a
* SHGetFolderPathFlags
2

-- Handles Windows APIs that write strings through a user-provided buffer and

-- can propose a new length when it isn't big enough. This is similar to

-- Win32.try, but also returns the precise error code.

peekTStringWith :: Win32.DWORD
                -> (Win32.LPTSTR -> Win32.DWORD -> IO Win32.DWORD)
                -- ^ Must accept a buffer and its size in TCHARs. If the

                --   buffer is large enough for the function, it must write a

                --   string to it, which need not be null-terminated, and

                --   return the length of the string, not including the null

                --   terminator if present. If the buffer is too small, it

                --   must return a proposed buffer size in TCHARs, although it

                --   need not guarantee success with the proposed size if,

                --   say, the underlying data changes in the interim. If it

                --   fails for any other reason, it must return zero and

                --   communicate the error code through GetLastError.

                -> IO (Either Win32.ErrCode WindowsPath)
peekTStringWith :: SHGetFolderPathFlags
-> (LPTSTR -> SHGetFolderPathFlags -> IO SHGetFolderPathFlags)
-> IO (Either SHGetFolderPathFlags WindowsPath)
peekTStringWith SHGetFolderPathFlags
bufferSize LPTSTR -> SHGetFolderPathFlags -> IO SHGetFolderPathFlags
cFunc = do
  outcome <- do
    Int
-> (LPTSTR
    -> IO
         (Either
            SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath)))
-> IO
     (Either
        SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath))
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (SHGetFolderPathFlags -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral SHGetFolderPathFlags
bufferSize) ((LPTSTR
  -> IO
       (Either
          SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath)))
 -> IO
      (Either
         SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath)))
-> (LPTSTR
    -> IO
         (Either
            SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath)))
-> IO
     (Either
        SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath))
forall a b. (a -> b) -> a -> b
$ \ LPTSTR
ptr -> do
      size <- LPTSTR -> SHGetFolderPathFlags -> IO SHGetFolderPathFlags
cFunc LPTSTR
ptr SHGetFolderPathFlags
bufferSize
      case size of
        SHGetFolderPathFlags
0 -> Either SHGetFolderPathFlags WindowsPath
-> Either
     SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath)
forall a b. b -> Either a b
Right (Either SHGetFolderPathFlags WindowsPath
 -> Either
      SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath))
-> (SHGetFolderPathFlags
    -> Either SHGetFolderPathFlags WindowsPath)
-> SHGetFolderPathFlags
-> Either
     SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SHGetFolderPathFlags -> Either SHGetFolderPathFlags WindowsPath
forall a b. a -> Either a b
Left (SHGetFolderPathFlags
 -> Either
      SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath))
-> IO SHGetFolderPathFlags
-> IO
     (Either
        SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO SHGetFolderPathFlags
Win32.getLastError
        SHGetFolderPathFlags
_ | SHGetFolderPathFlags
size SHGetFolderPathFlags -> SHGetFolderPathFlags -> Bool
forall a. Ord a => a -> a -> Bool
<= SHGetFolderPathFlags
bufferSize ->
              Either SHGetFolderPathFlags WindowsPath
-> Either
     SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath)
forall a b. b -> Either a b
Right (Either SHGetFolderPathFlags WindowsPath
 -> Either
      SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath))
-> (WindowsPath -> Either SHGetFolderPathFlags WindowsPath)
-> WindowsPath
-> Either
     SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowsPath -> Either SHGetFolderPathFlags WindowsPath
forall a b. b -> Either a b
Right (WindowsPath
 -> Either
      SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath))
-> IO WindowsPath
-> IO
     (Either
        SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LPTSTR, Int) -> IO WindowsPath
Win32.peekTStringLen (LPTSTR
ptr, SHGetFolderPathFlags -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral SHGetFolderPathFlags
size)
          | Bool
otherwise ->
              -- At least double the size to ensure fast termination.

              Either
  SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath)
-> IO
     (Either
        SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SHGetFolderPathFlags
-> Either
     SHGetFolderPathFlags (Either SHGetFolderPathFlags WindowsPath)
forall a b. a -> Either a b
Left (SHGetFolderPathFlags
-> SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Ord a => a -> a -> a
max SHGetFolderPathFlags
size (SHGetFolderPathFlags -> SHGetFolderPathFlags
saturatingDouble SHGetFolderPathFlags
bufferSize)))
  case outcome of
    Left SHGetFolderPathFlags
proposedSize -> SHGetFolderPathFlags
-> (LPTSTR -> SHGetFolderPathFlags -> IO SHGetFolderPathFlags)
-> IO (Either SHGetFolderPathFlags WindowsPath)
peekTStringWith SHGetFolderPathFlags
proposedSize LPTSTR -> SHGetFolderPathFlags -> IO SHGetFolderPathFlags
cFunc
    Right Either SHGetFolderPathFlags WindowsPath
result      -> Either SHGetFolderPathFlags WindowsPath
-> IO (Either SHGetFolderPathFlags WindowsPath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either SHGetFolderPathFlags WindowsPath
result

realPath :: OsPath -> IO OsPath
realPath :: OsPath -> IO OsPath
realPath = OsPath -> IO OsPath
getFinalPathName

canonicalizePathSimplify :: OsPath -> IO OsPath
canonicalizePathSimplify :: OsPath -> IO OsPath
canonicalizePathSimplify OsPath
path =
  OsPath -> IO OsPath
getFullPathName OsPath
path
    IO OsPath -> (IOError -> IO OsPath) -> IO OsPath
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \ IOError
_ ->
      OsPath -> IO OsPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OsPath
path

searchPathEnvForExes :: OsString -> IO (Maybe OsPath)
searchPathEnvForExes :: OsPath -> IO (Maybe OsPath)
searchPathEnvForExes (OsString WindowsPath
binary) = IO (Maybe OsPath)
search IO (Maybe OsPath)
-> (IOError -> IO (Maybe OsPath)) -> IO (Maybe OsPath)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \IOError
e ->
  if IOError -> IOErrorType
ioeGetErrorType IOError
e IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
InvalidArgument
  then 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
  else IOError -> IO (Maybe OsPath)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO IOError
e
 where
  search :: IO (Maybe OsPath)
search = (WindowsPath -> OsPath
OsString (WindowsPath -> OsPath) -> Maybe WindowsPath -> Maybe OsPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Maybe WindowsPath -> Maybe OsPath)
-> IO (Maybe WindowsPath) -> IO (Maybe OsPath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe WindowsPath
-> WindowsPath -> Maybe WindowsPath -> IO (Maybe WindowsPath)
Win32.searchPath Maybe WindowsPath
forall a. Maybe a
Nothing WindowsPath
binary (WindowsPath -> Maybe WindowsPath
forall a. a -> Maybe a
Just (OsPath -> WindowsPath
getOsString OsPath
exeExtension))

findExecutablesLazyInternal :: ([OsPath] -> OsString -> ListT IO OsPath)
                            -> OsString
                            -> ListT IO OsPath
findExecutablesLazyInternal :: ([OsPath] -> OsPath -> ListT IO OsPath)
-> OsPath -> ListT IO OsPath
findExecutablesLazyInternal [OsPath] -> OsPath -> ListT IO OsPath
_ = IO (Maybe OsPath) -> ListT IO OsPath
forall (m :: * -> *) a. Applicative m => m (Maybe a) -> ListT m a
maybeToListT (IO (Maybe OsPath) -> ListT IO OsPath)
-> (OsPath -> IO (Maybe OsPath)) -> OsPath -> ListT IO OsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OsPath -> IO (Maybe OsPath)
searchPathEnvForExes

exeExtensionInternal :: OsString
exeExtensionInternal :: OsPath
exeExtensionInternal = OsPath
exeExtension

readDirToEnd :: RawHandle -> IO [OsPath]
readDirToEnd :: OsPath -> IO [OsPath]
readDirToEnd = OsPath -> IO [OsPath]
getDirectoryContentsInternal

getDirectoryContentsInternal :: OsPath -> IO [OsPath]
getDirectoryContentsInternal :: OsPath -> IO [OsPath]
getDirectoryContentsInternal OsPath
path = do
  query <- OsPath -> IO WindowsPath
furnishPath (OsPath
path OsPath -> OsPath -> OsPath
</> [Char] -> OsPath
os [Char]
"*")
  bracket
    (Win32.findFirstFile query)
    (\ (HANDLE
h, FindData
_) -> HANDLE -> IO ()
Win32.findClose HANDLE
h)
    (\ (HANDLE
h, FindData
fdat) -> HANDLE -> FindData -> [OsPath] -> IO [OsPath]
loop HANDLE
h FindData
fdat [])
  where
    -- we needn't worry about empty directories: a directory always

    -- has at least "." and ".." entries

    loop :: Win32.HANDLE -> Win32.FindData -> [OsPath] -> IO [OsPath]
    loop :: HANDLE -> FindData -> [OsPath] -> IO [OsPath]
loop HANDLE
h FindData
fdat [OsPath]
acc = do
      filename <- FindData -> IO WindowsPath
Win32.getFindDataFileName FindData
fdat
      more <- Win32.findNextFile h fdat
      if more
        then loop h fdat (OsString filename : acc)
        else pure (OsString filename : acc)
             -- no need to reverse, ordering is undefined


getCurrentDirectoryInternal :: IO OsPath
getCurrentDirectoryInternal :: IO OsPath
getCurrentDirectoryInternal = WindowsPath -> OsPath
OsString (WindowsPath -> OsPath) -> IO WindowsPath -> IO OsPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO WindowsPath
Win32.getCurrentDirectory

getFullPathName :: OsPath -> IO OsPath
getFullPathName :: OsPath -> IO OsPath
getFullPathName OsPath
path =
  WindowsPath -> OsPath
fromExtendedLengthPath (WindowsPath -> OsPath) -> IO WindowsPath -> IO OsPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WindowsPath -> IO WindowsPath
Win32.getFullPathName (OsPath -> WindowsPath
toExtendedLengthPath OsPath
path)

-- | Similar to 'prependCurrentDirectory' but fails for empty paths.

rawPrependCurrentDirectory :: OsPath -> IO OsPath
rawPrependCurrentDirectory :: OsPath -> IO OsPath
rawPrependCurrentDirectory OsPath
path
  | OsPath -> Bool
isRelative OsPath
path =
    ((IOError -> [Char] -> IOError
`ioeAddLocation` [Char]
"prependCurrentDirectory") (IOError -> IOError) -> (IOError -> IOError) -> IOError -> IOError
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
     (IOError -> OsPath -> IOError
`ioeSetOsPath` OsPath
path)) (IOError -> IOError) -> IO OsPath -> IO OsPath
forall a. (IOError -> IOError) -> IO a -> IO a
`modifyIOError` do
      OsPath -> IO OsPath
getFullPathName OsPath
path
  | Bool
otherwise = OsPath -> IO OsPath
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OsPath
path

-- | Convert a path into an absolute path.  If the given path is relative, the

-- current directory is prepended and the path may or may not be simplified.

-- If the path is already absolute, the path is returned unchanged.  The

-- function preserves the presence or absence of the trailing path separator.

--

-- If the path is already absolute, the operation never fails.  Otherwise, the

-- operation may throw exceptions.

--

-- Empty paths are treated as the current directory.

prependCurrentDirectory :: OsPath -> IO OsPath
prependCurrentDirectory :: OsPath -> IO OsPath
prependCurrentDirectory = OsPath -> IO OsPath
rawPrependCurrentDirectory (OsPath -> IO OsPath) -> (OsPath -> OsPath) -> OsPath -> IO OsPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OsPath -> OsPath
emptyToCurDir

-- SetCurrentDirectory does not support long paths even with the \\?\ prefix

-- https://ghc.haskell.org/trac/ghc/ticket/13373#comment:6

setCurrentDirectoryInternal :: OsPath -> IO ()
setCurrentDirectoryInternal :: OsPath -> IO ()
setCurrentDirectoryInternal = WindowsPath -> IO ()
Win32.setCurrentDirectory (WindowsPath -> IO ())
-> (OsPath -> WindowsPath) -> OsPath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OsPath -> WindowsPath
getOsString

createSymbolicLinkUnpriv :: WindowsPath -> WindowsPath -> Bool -> IO ()
createSymbolicLinkUnpriv :: WindowsPath -> WindowsPath -> Bool -> IO ()
createSymbolicLinkUnpriv WindowsPath
link WindowsPath
_target Bool
_isDir =

{-# LINE 485 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
  Win32.withTString link $ \ pLink ->
  Win32.withTString _target $ \ pTarget -> do
    let flags = if _isDir then win32_sYMBOLIC_LINK_FLAG_DIRECTORY else 0
    call pLink pTarget flags win32_sYMBOLIC_LINK_FLAG_ALLOW_UNPRIVILEGED_CREATE
  where
    call :: LPTSTR
-> LPTSTR -> SHGetFolderPathFlags -> SHGetFolderPathFlags -> IO ()
call LPTSTR
pLink LPTSTR
pTarget SHGetFolderPathFlags
flags SHGetFolderPathFlags
unpriv = do
      status <- LPTSTR -> LPTSTR -> SHGetFolderPathFlags -> IO BYTE
c_CreateSymbolicLink LPTSTR
pLink LPTSTR
pTarget (SHGetFolderPathFlags
flags SHGetFolderPathFlags
-> SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Bits a => a -> a -> a
.|. SHGetFolderPathFlags
unpriv)
      when (status == 0) $ do
        e <- Win32.getLastError
        case () of
          ()
_ | SHGetFolderPathFlags
e SHGetFolderPathFlags -> SHGetFolderPathFlags -> Bool
forall a. Eq a => a -> a -> Bool
== SHGetFolderPathFlags
win32_eRROR_INVALID_FUNCTION -> do
                let msg :: [Char]
msg = [Char]
"Incorrect function. The underlying file system " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
                          [Char]
"might not support symbolic links."
                IOError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (IOErrorType -> [Char] -> Maybe Handle -> Maybe [Char] -> IOError
mkIOError IOErrorType
illegalOperationErrorType
                                   [Char]
"CreateSymbolicLink" Maybe Handle
forall a. Maybe a
Nothing Maybe [Char]
forall a. Maybe a
Nothing
                         IOError -> OsPath -> IOError
`ioeSetOsPath` WindowsPath -> OsPath
OsString WindowsPath
link
                         IOError -> [Char] -> IOError
`ioeSetErrorString` [Char]
msg)
            | SHGetFolderPathFlags
e SHGetFolderPathFlags -> SHGetFolderPathFlags -> Bool
forall a. Eq a => a -> a -> Bool
== SHGetFolderPathFlags
win32_eRROR_PRIVILEGE_NOT_HELD -> do
                let msg :: [Char]
msg = [Char]
"A required privilege is not held by the client. " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
                          [Char]
"Creating symbolic links usually requires " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
                          [Char]
"administrative rights."
                IOError -> IO ()
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (IOErrorType -> [Char] -> Maybe Handle -> Maybe [Char] -> IOError
mkIOError IOErrorType
permissionErrorType [Char]
"CreateSymbolicLink"
                                   Maybe Handle
forall a. Maybe a
Nothing Maybe [Char]
forall a. Maybe a
Nothing
                         IOError -> OsPath -> IOError
`ioeSetOsPath` WindowsPath -> OsPath
OsString WindowsPath
link
                         IOError -> [Char] -> IOError
`ioeSetErrorString` [Char]
msg)
            | SHGetFolderPathFlags
e SHGetFolderPathFlags -> SHGetFolderPathFlags -> Bool
forall a. Eq a => a -> a -> Bool
== SHGetFolderPathFlags
win32_eRROR_INVALID_PARAMETER Bool -> Bool -> Bool
&&
              SHGetFolderPathFlags
unpriv SHGetFolderPathFlags -> SHGetFolderPathFlags -> Bool
forall a. Eq a => a -> a -> Bool
/= SHGetFolderPathFlags
0 ->
                -- for compatibility with older versions of Windows,

                -- try it again without the flag

                LPTSTR
-> LPTSTR -> SHGetFolderPathFlags -> SHGetFolderPathFlags -> IO ()
call LPTSTR
pLink LPTSTR
pTarget SHGetFolderPathFlags
flags SHGetFolderPathFlags
0
            | Bool
otherwise -> [Char] -> SHGetFolderPathFlags -> IO ()
forall a. [Char] -> SHGetFolderPathFlags -> IO a
Win32.failWith [Char]
"CreateSymbolicLink" SHGetFolderPathFlags
e

foreign import WINAPI unsafe "windows.h CreateSymbolicLinkW"
  c_CreateSymbolicLink
    :: Ptr CWchar -> Ptr CWchar -> Win32.DWORD -> IO Win32.BYTE


{-# LINE 528 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}

linkToDirectoryIsDirectory :: Bool
linkToDirectoryIsDirectory :: Bool
linkToDirectoryIsDirectory = Bool
True

createSymbolicLink :: Bool -> OsPath -> OsPath -> IO ()
createSymbolicLink :: Bool -> OsPath -> OsPath -> IO ()
createSymbolicLink Bool
isDir OsPath
target OsPath
link =
  (IOError -> OsPath -> IOError
`ioeSetOsPath` OsPath
link) (IOError -> IOError) -> IO () -> IO ()
forall a. (IOError -> IOError) -> IO a -> IO a
`modifyIOError` do
    -- normaliseSeparators ensures the target gets normalised properly

    link' <- OsPath -> IO WindowsPath
furnishPath OsPath
link
    createSymbolicLinkUnpriv
      link'
      (normaliseSeparators target)
      isDir

type Metadata = Win32.BY_HANDLE_FILE_INFORMATION

getMetadataAt :: WhetherFollow -> Maybe RawHandle -> OsPath -> IO Metadata
getMetadataAt :: WhetherFollow -> Maybe OsPath -> OsPath -> IO Metadata
getMetadataAt WhetherFollow
NoFollow    Maybe OsPath
dir OsPath
path = OsPath -> IO Metadata
getSymbolicLinkMetadata (Maybe OsPath -> OsPath -> OsPath
pathAt Maybe OsPath
dir OsPath
path)
getMetadataAt WhetherFollow
FollowLinks Maybe OsPath
dir OsPath
path = OsPath -> IO Metadata
getFileMetadata         (Maybe OsPath -> OsPath -> OsPath
pathAt Maybe OsPath
dir OsPath
path)

getSymbolicLinkMetadata :: OsPath -> IO Metadata
getSymbolicLinkMetadata :: OsPath -> IO Metadata
getSymbolicLinkMetadata OsPath
path =
  (IOError -> OsPath -> IOError
`ioeSetOsPath` OsPath
path) (IOError -> IOError) -> IO Metadata -> IO Metadata
forall a. (IOError -> IOError) -> IO a -> IO a
`modifyIOError` do
    path' <- OsPath -> IO WindowsPath
furnishPath OsPath
path
    let open = WindowsPath
-> SHGetFolderPathFlags
-> SHGetFolderPathFlags
-> Maybe LPSECURITY_ATTRIBUTES
-> SHGetFolderPathFlags
-> SHGetFolderPathFlags
-> Maybe HANDLE
-> IO HANDLE
Win32.createFile WindowsPath
path' SHGetFolderPathFlags
0 SHGetFolderPathFlags
maxShareMode Maybe LPSECURITY_ATTRIBUTES
forall a. Maybe a
Nothing SHGetFolderPathFlags
Win32.oPEN_EXISTING
                                (SHGetFolderPathFlags
Win32.fILE_FLAG_BACKUP_SEMANTICS SHGetFolderPathFlags
-> SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Bits a => a -> a -> a
.|.
                                 SHGetFolderPathFlags
win32_fILE_FLAG_OPEN_REPARSE_POINT) Maybe HANDLE
forall a. Maybe a
Nothing
    bracket open Win32.closeHandle $ \ HANDLE
h -> do
      HANDLE -> IO Metadata
Win32.getFileInformationByHandle HANDLE
h

getFileMetadata :: OsPath -> IO Metadata
getFileMetadata :: OsPath -> IO Metadata
getFileMetadata OsPath
path =
  (IOError -> OsPath -> IOError
`ioeSetOsPath` OsPath
path) (IOError -> IOError) -> IO Metadata -> IO Metadata
forall a. (IOError -> IOError) -> IO a -> IO a
`modifyIOError` do
    path' <- OsPath -> IO WindowsPath
furnishPath OsPath
path
    let open = WindowsPath
-> SHGetFolderPathFlags
-> SHGetFolderPathFlags
-> Maybe LPSECURITY_ATTRIBUTES
-> SHGetFolderPathFlags
-> SHGetFolderPathFlags
-> Maybe HANDLE
-> IO HANDLE
Win32.createFile WindowsPath
path' SHGetFolderPathFlags
0 SHGetFolderPathFlags
maxShareMode Maybe LPSECURITY_ATTRIBUTES
forall a. Maybe a
Nothing SHGetFolderPathFlags
Win32.oPEN_EXISTING
                                SHGetFolderPathFlags
Win32.fILE_FLAG_BACKUP_SEMANTICS Maybe HANDLE
forall a. Maybe a
Nothing
    bracket open Win32.closeHandle $ \ HANDLE
h -> do
      HANDLE -> IO Metadata
Win32.getFileInformationByHandle HANDLE
h

fileTypeFromMetadata :: Metadata -> FileType
fileTypeFromMetadata :: Metadata -> FileType
fileTypeFromMetadata Metadata
info
  | Bool
isLink    = if Bool
isDir then FileType
DirectoryLink else FileType
SymbolicLink
  | Bool
isDir     = FileType
Directory
  | Bool
otherwise = FileType
File
  where
    isLink :: Bool
isLink = SHGetFolderPathFlags
attrs SHGetFolderPathFlags
-> SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Bits a => a -> a -> a
.&. SHGetFolderPathFlags
Win32.fILE_ATTRIBUTE_REPARSE_POINT SHGetFolderPathFlags -> SHGetFolderPathFlags -> Bool
forall a. Eq a => a -> a -> Bool
/= SHGetFolderPathFlags
0
    isDir :: Bool
isDir  = SHGetFolderPathFlags
attrs SHGetFolderPathFlags
-> SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Bits a => a -> a -> a
.&. SHGetFolderPathFlags
Win32.fILE_ATTRIBUTE_DIRECTORY SHGetFolderPathFlags -> SHGetFolderPathFlags -> Bool
forall a. Eq a => a -> a -> Bool
/= SHGetFolderPathFlags
0
    attrs :: SHGetFolderPathFlags
attrs  = Metadata -> SHGetFolderPathFlags
Win32.bhfiFileAttributes Metadata
info

fileSizeFromMetadata :: Metadata -> Integer
fileSizeFromMetadata :: Metadata -> Integer
fileSizeFromMetadata = DDWORD -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DDWORD -> Integer) -> (Metadata -> DDWORD) -> Metadata -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Metadata -> DDWORD
Win32.bhfiSize

accessTimeFromMetadata :: Metadata -> UTCTime
accessTimeFromMetadata :: Metadata -> UTCTime
accessTimeFromMetadata =
  POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime)
-> (Metadata -> POSIXTime) -> Metadata -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FILETIME -> POSIXTime
windowsToPosixTime (FILETIME -> POSIXTime)
-> (Metadata -> FILETIME) -> Metadata -> POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Metadata -> FILETIME
Win32.bhfiLastAccessTime

modificationTimeFromMetadata :: Metadata -> UTCTime
modificationTimeFromMetadata :: Metadata -> UTCTime
modificationTimeFromMetadata =
  POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime)
-> (Metadata -> POSIXTime) -> Metadata -> UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FILETIME -> POSIXTime
windowsToPosixTime (FILETIME -> POSIXTime)
-> (Metadata -> FILETIME) -> Metadata -> POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Metadata -> FILETIME
Win32.bhfiLastWriteTime

-- | Difference between the Windows and POSIX epochs in units of 100ns.

windowsPosixEpochDifference :: Num a => a
windowsPosixEpochDifference :: forall a. Num a => a
windowsPosixEpochDifference = a
116444736000000000

-- | Convert from Windows time to POSIX time.

windowsToPosixTime :: Win32.FILETIME -> POSIXTime
windowsToPosixTime :: FILETIME -> POSIXTime
windowsToPosixTime (Win32.FILETIME DDWORD
t) =
  (DDWORD -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral DDWORD
t POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- POSIXTime
forall a. Num a => a
windowsPosixEpochDifference) POSIXTime -> POSIXTime -> POSIXTime
forall a. Fractional a => a -> a -> a
/ POSIXTime
10000000

-- | Convert from POSIX time to Windows time.  This is lossy as Windows time

--   has a resolution of only 100ns.

posixToWindowsTime :: POSIXTime -> Win32.FILETIME
posixToWindowsTime :: POSIXTime -> FILETIME
posixToWindowsTime POSIXTime
t = DDWORD -> FILETIME
Win32.FILETIME (DDWORD -> FILETIME) -> DDWORD -> FILETIME
forall a b. (a -> b) -> a -> b
$
  POSIXTime -> DDWORD
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (POSIXTime
t POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
* POSIXTime
10000000 POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
+ POSIXTime
forall a. Num a => a
windowsPosixEpochDifference)

setTimes :: OsPath -> (Maybe POSIXTime, Maybe POSIXTime) -> IO ()
setTimes :: OsPath -> (Maybe POSIXTime, Maybe POSIXTime) -> IO ()
setTimes OsPath
path' (Maybe POSIXTime
atime', Maybe POSIXTime
mtime') =
  IO HANDLE -> (HANDLE -> IO ()) -> (HANDLE -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (OsPath -> SHGetFolderPathFlags -> IO HANDLE
openFileHandle OsPath
path' SHGetFolderPathFlags
Win32.gENERIC_WRITE)
          HANDLE -> IO ()
Win32.closeHandle ((HANDLE -> IO ()) -> IO ()) -> (HANDLE -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ HANDLE
handle ->
  HANDLE
-> Maybe FILETIME -> Maybe FILETIME -> Maybe FILETIME -> IO ()
Win32.setFileTime HANDLE
handle Maybe FILETIME
forall a. Maybe a
Nothing (POSIXTime -> FILETIME
posixToWindowsTime (POSIXTime -> FILETIME) -> Maybe POSIXTime -> Maybe FILETIME
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe POSIXTime
atime') (POSIXTime -> FILETIME
posixToWindowsTime (POSIXTime -> FILETIME) -> Maybe POSIXTime -> Maybe FILETIME
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe POSIXTime
mtime')

-- | Open the handle of an existing file or directory.

openFileHandle :: OsString -> Win32.AccessMode -> IO Win32.HANDLE
openFileHandle :: OsPath -> SHGetFolderPathFlags -> IO HANDLE
openFileHandle OsPath
path SHGetFolderPathFlags
mode =
  (IOError -> OsPath -> IOError
`ioeSetOsPath` OsPath
path) (IOError -> IOError) -> IO HANDLE -> IO HANDLE
forall a. (IOError -> IOError) -> IO a -> IO a
`modifyIOError` do
    path' <- OsPath -> IO WindowsPath
furnishPath OsPath
path
    Win32.createFile path' mode maxShareMode Nothing
                     Win32.oPEN_EXISTING flags Nothing
  where flags :: SHGetFolderPathFlags
flags =  SHGetFolderPathFlags
Win32.fILE_ATTRIBUTE_NORMAL
             SHGetFolderPathFlags
-> SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Bits a => a -> a -> a
.|. SHGetFolderPathFlags
Win32.fILE_FLAG_BACKUP_SEMANTICS -- required for directories


type Mode = Win32.FileAttributeOrFlag

modeFromMetadata :: Metadata -> Mode
modeFromMetadata :: Metadata -> SHGetFolderPathFlags
modeFromMetadata = Metadata -> SHGetFolderPathFlags
Win32.bhfiFileAttributes

hasWriteMode :: Mode -> Bool
hasWriteMode :: SHGetFolderPathFlags -> Bool
hasWriteMode SHGetFolderPathFlags
m = SHGetFolderPathFlags
m SHGetFolderPathFlags
-> SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Bits a => a -> a -> a
.&. SHGetFolderPathFlags
Win32.fILE_ATTRIBUTE_READONLY SHGetFolderPathFlags -> SHGetFolderPathFlags -> Bool
forall a. Eq a => a -> a -> Bool
== SHGetFolderPathFlags
0

setWriteMode :: Bool -> Mode -> Mode
setWriteMode :: Bool -> SHGetFolderPathFlags -> SHGetFolderPathFlags
setWriteMode Bool
False SHGetFolderPathFlags
m = SHGetFolderPathFlags
m SHGetFolderPathFlags
-> SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Bits a => a -> a -> a
.|. SHGetFolderPathFlags
Win32.fILE_ATTRIBUTE_READONLY
setWriteMode Bool
True  SHGetFolderPathFlags
m = SHGetFolderPathFlags
m SHGetFolderPathFlags
-> SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Bits a => a -> a -> a
.&. SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Bits a => a -> a
complement SHGetFolderPathFlags
Win32.fILE_ATTRIBUTE_READONLY

setForceRemoveMode :: Mode -> Mode
setForceRemoveMode :: SHGetFolderPathFlags -> SHGetFolderPathFlags
setForceRemoveMode SHGetFolderPathFlags
m = SHGetFolderPathFlags
m SHGetFolderPathFlags
-> SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Bits a => a -> a -> a
.&. SHGetFolderPathFlags -> SHGetFolderPathFlags
forall a. Bits a => a -> a
complement SHGetFolderPathFlags
Win32.fILE_ATTRIBUTE_READONLY

setModeAt :: WhetherFollow -> Maybe RawHandle -> OsPath -> Mode -> IO ()
setModeAt :: WhetherFollow
-> Maybe OsPath -> OsPath -> SHGetFolderPathFlags -> IO ()
setModeAt WhetherFollow
_ Maybe OsPath
dir OsPath
path = OsPath -> SHGetFolderPathFlags -> IO ()
setFileMode (Maybe OsPath -> OsPath -> OsPath
pathAt Maybe OsPath
dir OsPath
path)

setFileMode :: OsPath -> Mode -> IO ()
setFileMode :: OsPath -> SHGetFolderPathFlags -> IO ()
setFileMode OsPath
path SHGetFolderPathFlags
mode =
  (IOError -> OsPath -> IOError
`ioeSetOsPath` OsPath
path) (IOError -> IOError) -> IO () -> IO ()
forall a. (IOError -> IOError) -> IO a -> IO a
`modifyIOError` do
    path' <- OsPath -> IO WindowsPath
furnishPath OsPath
path
    Win32.setFileAttributes path' mode

-- | A restricted form of 'setFileMode' that only sets the permission bits.

-- For Windows, this means only the "read-only" attribute is affected.

setFilePermissions :: OsPath -> Mode -> IO ()
setFilePermissions :: OsPath -> SHGetFolderPathFlags -> IO ()
setFilePermissions OsPath
path SHGetFolderPathFlags
m = do
  m' <- Metadata -> SHGetFolderPathFlags
modeFromMetadata (Metadata -> SHGetFolderPathFlags)
-> IO Metadata -> IO SHGetFolderPathFlags
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OsPath -> IO Metadata
getFileMetadata OsPath
path
  setFileMode path ((m' .&. complement Win32.fILE_ATTRIBUTE_READONLY) .|.
                    (m  .&. Win32.fILE_ATTRIBUTE_READONLY))

getAccessPermissions :: OsPath -> IO Permissions
getAccessPermissions :: OsPath -> IO Permissions
getAccessPermissions OsPath
path = do
  m <- OsPath -> IO Metadata
getFileMetadata OsPath
path
  let isDir = FileType -> Bool
fileTypeIsDirectory (Metadata -> FileType
fileTypeFromMetadata Metadata
m)
  let w = SHGetFolderPathFlags -> Bool
hasWriteMode (Metadata -> SHGetFolderPathFlags
modeFromMetadata Metadata
m)
  let x = (Char -> Char
toLower (Char -> Char) -> (OsChar -> Char) -> OsChar -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OsChar -> Char
toChar (OsChar -> Char) -> [OsChar] -> [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OsPath -> [OsChar]
unpack (OsPath -> OsPath
takeExtension OsPath
path))
          [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
".bat", [Char]
".cmd", [Char]
".com", [Char]
".exe"]
  pure Permissions
       { readable   = True
       , writable   = w
       , executable = x && not isDir
       , searchable = isDir
       }

setAccessPermissions :: OsPath -> Permissions -> IO ()
setAccessPermissions :: OsPath -> Permissions -> IO ()
setAccessPermissions OsPath
path Permissions{writable :: Permissions -> Bool
writable = Bool
w} = do
  OsPath -> SHGetFolderPathFlags -> IO ()
setFilePermissions OsPath
path (Bool -> SHGetFolderPathFlags -> SHGetFolderPathFlags
setWriteMode Bool
w SHGetFolderPathFlags
0)

lookupEnvOs :: OsString -> IO (Maybe OsString)
lookupEnvOs :: OsPath -> IO (Maybe OsPath)
lookupEnvOs (OsString WindowsPath
name) = do
  result <-
    WindowsPath
-> (LPTSTR -> IO (Either SHGetFolderPathFlags WindowsPath))
-> IO (Either SHGetFolderPathFlags WindowsPath)
forall a. WindowsPath -> (LPTSTR -> IO a) -> IO a
Win32.withTString WindowsPath
name ((LPTSTR -> IO (Either SHGetFolderPathFlags WindowsPath))
 -> IO (Either SHGetFolderPathFlags WindowsPath))
-> (LPTSTR -> IO (Either SHGetFolderPathFlags WindowsPath))
-> IO (Either SHGetFolderPathFlags WindowsPath)
forall a b. (a -> b) -> a -> b
$ \ LPTSTR
pName ->
    SHGetFolderPathFlags
-> (LPTSTR -> SHGetFolderPathFlags -> IO SHGetFolderPathFlags)
-> IO (Either SHGetFolderPathFlags WindowsPath)
peekTStringWith SHGetFolderPathFlags
256 ((LPTSTR -> SHGetFolderPathFlags -> IO SHGetFolderPathFlags)
 -> IO (Either SHGetFolderPathFlags WindowsPath))
-> (LPTSTR -> SHGetFolderPathFlags -> IO SHGetFolderPathFlags)
-> IO (Either SHGetFolderPathFlags WindowsPath)
forall a b. (a -> b) -> a -> b
$ \ LPTSTR
pBuffer SHGetFolderPathFlags
size ->
    LPTSTR -> LPTSTR -> SHGetFolderPathFlags -> IO SHGetFolderPathFlags
c_GetEnvironmentVariable LPTSTR
pName LPTSTR
pBuffer SHGetFolderPathFlags
size
  case result of
    Left SHGetFolderPathFlags
errCode | SHGetFolderPathFlags
errCode SHGetFolderPathFlags -> SHGetFolderPathFlags -> Bool
forall a. Eq a => a -> a -> Bool
== SHGetFolderPathFlags
win32_eRROR_ENVVAR_NOT_FOUND -> 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
                 | Bool
otherwise -> [Char] -> SHGetFolderPathFlags -> IO (Maybe OsPath)
forall a. [Char] -> SHGetFolderPathFlags -> IO a
Win32.failWith [Char]
"GetEnvironmentVariable" SHGetFolderPathFlags
errCode
    Right WindowsPath
value -> Maybe OsPath -> IO (Maybe OsPath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OsPath -> Maybe OsPath
forall a. a -> Maybe a
Just (WindowsPath -> OsPath
OsString WindowsPath
value))

foreign import WINAPI unsafe "windows.h GetEnvironmentVariableW"
  c_GetEnvironmentVariable
    :: Win32.LPWSTR
    -> Win32.LPWSTR
    -> Win32.DWORD
    -> IO Win32.DWORD

getFolderPath :: Win32.CSIDL -> IO OsPath
getFolderPath :: CSIDL -> IO OsPath
getFolderPath CSIDL
what = WindowsPath -> OsPath
OsString (WindowsPath -> OsPath) -> IO WindowsPath -> IO OsPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HANDLE -> CSIDL -> HANDLE -> SHGetFolderPathFlags -> IO WindowsPath
Win32.sHGetFolderPath HANDLE
forall {b}. Ptr b
nullPtr CSIDL
what HANDLE
forall {b}. Ptr b
nullPtr SHGetFolderPathFlags
0

getHomeDirectoryInternal :: IO OsPath
getHomeDirectoryInternal :: IO OsPath
getHomeDirectoryInternal =
  CSIDL -> IO OsPath
getFolderPath CSIDL
Win32.cSIDL_PROFILE IO OsPath -> (IOError -> IO OsPath) -> IO OsPath
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` \ IOError
_ ->
    CSIDL -> IO OsPath
getFolderPath CSIDL
Win32.cSIDL_WINDOWS

getXdgDirectoryFallback :: IO OsPath -> XdgDirectory -> IO OsPath
getXdgDirectoryFallback :: IO OsPath -> XdgDirectory -> IO OsPath
getXdgDirectoryFallback IO OsPath
_ XdgDirectory
xdgDir = do
  case XdgDirectory
xdgDir of
    XdgDirectory
XdgData   -> CSIDL -> IO OsPath
getFolderPath CSIDL
Win32.cSIDL_APPDATA
    XdgDirectory
XdgConfig -> CSIDL -> IO OsPath
getFolderPath CSIDL
Win32.cSIDL_APPDATA
    XdgDirectory
XdgCache  -> CSIDL -> IO OsPath
getFolderPath CSIDL
Win32.cSIDL_LOCAL_APPDATA
    XdgDirectory
XdgState  -> CSIDL -> IO OsPath
getFolderPath CSIDL
Win32.cSIDL_LOCAL_APPDATA

getXdgDirectoryListFallback :: XdgDirectoryList -> IO [OsPath]
getXdgDirectoryListFallback :: XdgDirectoryList -> IO [OsPath]
getXdgDirectoryListFallback XdgDirectoryList
_ =
  OsPath -> [OsPath]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OsPath -> [OsPath]) -> IO OsPath -> IO [OsPath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CSIDL -> IO OsPath
getFolderPath CSIDL
win32_cSIDL_COMMON_APPDATA

getAppUserDataDirectoryInternal :: OsPath -> IO OsPath
getAppUserDataDirectoryInternal :: OsPath -> IO OsPath
getAppUserDataDirectoryInternal OsPath
appName =
  (\ OsPath
appData -> OsPath
appData OsPath -> OsPath -> OsPath
forall a. Semigroup a => a -> a -> a
<> ([Char] -> OsPath
os [Char]
"\\" OsPath -> OsPath -> OsPath
forall a. Semigroup a => a -> a -> a
<> OsPath
appName))
  (OsPath -> OsPath) -> IO OsPath -> IO OsPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO OsPath -> XdgDirectory -> IO OsPath
getXdgDirectoryFallback IO OsPath
getHomeDirectoryInternal XdgDirectory
XdgData

getUserDocumentsDirectoryInternal :: IO OsPath
getUserDocumentsDirectoryInternal :: IO OsPath
getUserDocumentsDirectoryInternal = CSIDL -> IO OsPath
getFolderPath CSIDL
Win32.cSIDL_PERSONAL

getTemporaryDirectoryInternal :: IO OsPath
getTemporaryDirectoryInternal :: IO OsPath
getTemporaryDirectoryInternal = WindowsPath -> OsPath
OsString (WindowsPath -> OsPath) -> IO WindowsPath -> IO OsPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO WindowsPath
Win32.getTemporaryDirectory


{-# LINE 719 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}