{-# 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 Data.Time (UTCTime)
import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)
import System.FilePath (addTrailingPathSeparator, hasTrailingPathSeparator,
                        isPathSeparator, isRelative, joinDrive, joinPath,
                        normalise, pathSeparator, pathSeparators,
                        splitDirectories, splitDrive, takeExtension)
import qualified Data.List as List
import qualified System.Win32 as Win32

win32_cSIDL_LOCAL_APPDATA :: Win32.CSIDL

{-# LINE 30 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
win32_cSIDL_LOCAL_APPDATA = Win32.cSIDL_LOCAL_APPDATA

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

win32_eRROR_INVALID_FUNCTION :: Win32.ErrCode
win32_eRROR_INVALID_FUNCTION = 0x1

win32_fILE_ATTRIBUTE_REPARSE_POINT :: Win32.FileAttributeOrFlag

{-# LINE 40 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
win32_fILE_ATTRIBUTE_REPARSE_POINT = Win32.fILE_ATTRIBUTE_REPARSE_POINT

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

win32_fILE_SHARE_DELETE :: Win32.ShareMode

{-# LINE 47 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
win32_fILE_SHARE_DELETE = Win32.fILE_SHARE_DELETE -- added in 2.3.0.2

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

maxShareMode :: Win32.ShareMode
maxShareMode =
  win32_fILE_SHARE_DELETE .|.
  Win32.fILE_SHARE_READ   .|.
  Win32.fILE_SHARE_WRITE

win32_getLongPathName, win32_getShortPathName :: FilePath -> IO FilePath

{-# LINE 60 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
win32_getLongPathName = Win32.getLongPathName
win32_getShortPathName = Win32.getShortPathName

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

win32_getFinalPathNameByHandle :: Win32.HANDLE -> Win32.DWORD -> IO FilePath
win32_getFinalPathNameByHandle _h _flags =
  modifyIOError (`ioeSetLocation` "GetFinalPathNameByHandle") $ do

{-# LINE 106 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
    throwIO (mkIOError UnsupportedOperation
             "platform does not support GetFinalPathNameByHandle"
             Nothing Nothing)

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

getFinalPathName :: FilePath -> IO FilePath
getFinalPathName =
  (fromExtendedLengthPath <$>) . rawGetFinalPathName . toExtendedLengthPath
  where

{-# LINE 122 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
    rawGetFinalPathName = win32_getLongPathName <=< win32_getShortPathName

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

win32_fILE_FLAG_OPEN_REPARSE_POINT :: Win32.FileAttributeOrFlag
win32_fILE_FLAG_OPEN_REPARSE_POINT = 0x00200000

win32_fSCTL_GET_REPARSE_POINT :: Win32.DWORD
win32_fSCTL_GET_REPARSE_POINT = 0x900a8

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

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

win32_sYMLINK_FLAG_RELATIVE :: CULong
win32_sYMLINK_FLAG_RELATIVE = 0x00000001

data Win32_REPARSE_DATA_BUFFER
  = Win32_MOUNT_POINT_REPARSE_DATA_BUFFER String String
    -- ^ substituteName printName
  | Win32_SYMLINK_REPARSE_DATA_BUFFER String String 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 action =
  allocaBytesAligned size align $ \ ptr ->
    action (ptr, size)
  where size = fromIntegral win32_mAXIMUM_REPARSE_DATA_BUFFER_SIZE
        -- workaround (hsc2hs for GHC < 8.0 don't support #{alignment ...})
        align = (4)
{-# LINE 157 "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 p = do
  tag <- (\hsc_ptr -> peekByteOff hsc_ptr 0) p
{-# LINE 162 "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 166 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          sni <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p
{-# LINE 168 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          sns <- (\hsc_ptr -> peekByteOff hsc_ptr 10) p
{-# LINE 170 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          sn <- peekName buf sni sns
          pni <- (\hsc_ptr -> peekByteOff hsc_ptr 12) p
{-# LINE 173 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          pns <- (\hsc_ptr -> peekByteOff hsc_ptr 14) p
{-# LINE 175 "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 180 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          sni <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p
{-# LINE 182 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          sns <- (\hsc_ptr -> peekByteOff hsc_ptr 10) p
{-# LINE 184 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          sn <- peekName buf sni sns
          pni <- (\hsc_ptr -> peekByteOff hsc_ptr 12) p
{-# LINE 187 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          pns <- (\hsc_ptr -> peekByteOff hsc_ptr 14) p
{-# LINE 189 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
          pn <- peekName buf pni pns
          flags <- (\hsc_ptr -> peekByteOff hsc_ptr 16) p
{-# LINE 192 "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 String
    peekName buf offset size =
      peekCWStringLen ( buf `plusPtr` fromIntegral offset
                      , fromIntegral size `div` sizeOf (0 :: CWchar) )

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

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 :: FilePath -> IO FilePath
readSymbolicLink path = modifyIOError (`ioeSetFileName` path) $ do
  path' <- toExtendedLengthPath <$> prependCurrentDirectory path
  let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING
                              (Win32.fILE_FLAG_BACKUP_SEMANTICS .|.
                              win32_fILE_FLAG_OPEN_REPARSE_POINT) Nothing
  bracket open Win32.closeHandle $ \ h -> do
    win32_alloca_REPARSE_DATA_BUFFER $ \ ptrAndSize@(ptr, _) -> do
      result <- deviceIoControl h win32_fSCTL_GET_REPARSE_POINT
                                (nullPtr, 0) ptrAndSize Nothing
      case result of
        Left e | e == win32_eRROR_INVALID_FUNCTION -> do
                   let msg = "Incorrect function. The file system " <>
                             "might not support symbolic links."
                   throwIO (mkIOError illegalOperationErrorType
                                      "DeviceIoControl" Nothing Nothing
                            `ioeSetErrorString` msg)
               | otherwise -> Win32.failWith "DeviceIoControl" e
        Right _ -> return ()
      rData <- win32_peek_REPARSE_DATA_BUFFER ptr
      strip <$> case rData of
        Win32_MOUNT_POINT_REPARSE_DATA_BUFFER sn _ -> pure sn
        Win32_SYMLINK_REPARSE_DATA_BUFFER sn _ _ -> pure sn
        _ -> throwIO (mkIOError InappropriateType
                                "readSymbolicLink" Nothing Nothing)
  where
    strip sn = fromMaybe sn (List.stripPrefix "\\??\\" sn)

-- | Given a list of path segments, expand @.@ and @..@.  The path segments
-- must not contain path separators.
expandDots :: [FilePath] -> [FilePath]
expandDots = reverse . go []
  where
    go ys' xs' =
      case xs' of
        [] -> ys'
        x : xs ->
          case x of
            "." -> go ys' xs
            ".." ->
              case ys' of
                _ : ys -> go ys xs
                [] -> go (x : ys') xs
            _ -> go (x : ys') xs

-- | Remove redundant trailing slashes and pick the right kind of slash.
normaliseTrailingSep :: FilePath -> FilePath
normaliseTrailingSep path = do
  let path' = reverse path
  let (sep, path'') = span isPathSeparator path'
  let addSep = if null sep then id else (pathSeparator :)
  reverse (addSep path'')

-- | A variant of 'normalise' to handle Windows paths a little better.  It
--
-- * deduplicates trailing slashes after the drive,
-- * expands parent dirs (@..@), and
-- * preserves paths with @\\\\?\\@.
normaliseW :: FilePath -> FilePath
normaliseW path@('\\' : '\\' : '?' : '\\' : _) = path
normaliseW path = normalise (joinDrive drive' subpath')
  where
    (drive, subpath) = splitDrive path
    drive' = normaliseTrailingSep drive
    subpath' = appendSep . prependSep . joinPath .
               stripPardirs . expandDots . skipSeps .
               splitDirectories $ subpath

    skipSeps = filter (not . (`elem` (pure <$> pathSeparators)))
    stripPardirs | not (isRelative path) = dropWhile (== "..")
                 | otherwise = id
    prependSep | any isPathSeparator (take 1 subpath) = (pathSeparator :)
               | otherwise = id
    appendSep | hasTrailingPathSeparator subpath = addTrailingPathSeparator
              | otherwise = id

-- | Like 'toExtendedLengthPath' but normalises relative paths too.
-- This is needed to make sure e.g. getModificationTime works on empty paths.
toNormalisedExtendedLengthPath :: FilePath -> FilePath
toNormalisedExtendedLengthPath path
  | isRelative path = normalise path
  | otherwise = toExtendedLengthPath path

-- | 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 :: FilePath -> FilePath
normaliseSeparators path
  | isRelative path = normaliseSep <$> path
  | otherwise = toExtendedLengthPath path
  where normaliseSep c = if isPathSeparator c then pathSeparator else c

-- | Add the @"\\\\?\\"@ prefix if necessary or possible.  The path remains
-- unchanged if the prefix is not added.  This function can sometimes be used
-- to bypass the @MAX_PATH@ length restriction in Windows API calls.
toExtendedLengthPath :: FilePath -> FilePath
toExtendedLengthPath path
  | isRelative path = path
  | otherwise =
      case normaliseW path of
        '\\' : '?'  : '?' : '\\' : _ -> path
        '\\' : '\\' : '?' : '\\' : _ -> path
        '\\' : '\\' : '.' : '\\' : _ -> path
        '\\' : subpath@('\\' : _) -> "\\\\?\\UNC" <> subpath
        normalisedPath -> "\\\\?\\" <> normalisedPath

-- | Strip the @"\\\\?\\"@ prefix if possible.
-- The prefix is kept if the meaning of the path would otherwise change.
fromExtendedLengthPath :: FilePath -> FilePath
fromExtendedLengthPath ePath =
  case ePath of
    '\\' : '\\' : '?' : '\\' : path ->
      case path of
        'U' : 'N' : 'C' : subpath@('\\' : _) -> "\\" <> subpath
        drive : ':' : subpath
          -- if the path is not "regular", then the prefix is necessary
          -- to ensure the path is interpreted literally
          | isAlpha drive && isAscii drive && isPathRegular subpath -> path
        _ -> ePath
    _ -> ePath
  where
    isPathRegular path =
      not ('/' `elem` path ||
           "." `elem` splitDirectories path ||
           ".." `elem` splitDirectories path)

getPathNameWith :: (Ptr CWchar -> Win32.DWORD -> IO Win32.DWORD) -> IO FilePath
getPathNameWith cFunc = do
  let getPathNameWithLen len = do
        allocaArray (fromIntegral len) $ \ ptrPathOut -> do
          len' <- Win32.failIfZero "" (cFunc ptrPathOut len)
          if len' <= len
            then Right <$> peekCWStringLen (ptrPathOut, fromIntegral len')
            else pure (Left len')
  r <- getPathNameWithLen ((260) * ((2)))
{-# LINE 365 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
  case r of
    Right s -> pure s
    Left len -> do
      r' <- getPathNameWithLen len
      case r' of
        Right s -> pure s
        Left _ -> throwIO (mkIOError OtherError "" Nothing Nothing
                           `ioeSetErrorString` "path changed unexpectedly")

win32_createSymbolicLink :: String -> String -> Bool -> IO ()
win32_createSymbolicLink link _target _isDir =

{-# LINE 413 "libraries\\directory\\System\\Directory\\Internal\\Windows.hsc" #-}
  throwIO . (`ioeSetErrorString` unsupportedErrorMsg) $
               mkIOError UnsupportedOperation "CreateSymbolicLink"
                         Nothing (Just link)
  where unsupportedErrorMsg = "Not supported on Windows XP or older"

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

createSymbolicLink :: Bool -> FilePath -> FilePath -> IO ()
createSymbolicLink isDir target link =
  (`ioeSetFileName` link) `modifyIOError` do
    -- normaliseSeparators ensures the target gets normalised properly
    link' <- toExtendedLengthPath <$> prependCurrentDirectory link
    win32_createSymbolicLink link' (normaliseSeparators target) isDir

type Metadata = Win32.BY_HANDLE_FILE_INFORMATION

getSymbolicLinkMetadata :: FilePath -> IO Metadata
getSymbolicLinkMetadata path =
  (`ioeSetFileName` path) `modifyIOError` do
    path' <- toNormalisedExtendedLengthPath <$> prependCurrentDirectory path
    let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING
                                (Win32.fILE_FLAG_BACKUP_SEMANTICS .|.
                                 win32_fILE_FLAG_OPEN_REPARSE_POINT) Nothing
    bracket open Win32.closeHandle $ \ h -> do
      Win32.getFileInformationByHandle h

getFileMetadata :: FilePath -> IO Metadata
getFileMetadata path =
  (`ioeSetFileName` path) `modifyIOError` do
    path' <- toNormalisedExtendedLengthPath <$> prependCurrentDirectory path
    let open = Win32.createFile path' 0 maxShareMode Nothing Win32.oPEN_EXISTING
                                Win32.fILE_FLAG_BACKUP_SEMANTICS Nothing
    bracket open Win32.closeHandle $ \ h -> do
      Win32.getFileInformationByHandle h

fileTypeFromMetadata :: Metadata -> FileType
fileTypeFromMetadata info
  | isLink    = if isDir then DirectoryLink else SymbolicLink
  | isDir     = Directory
  | otherwise = File
  where
    isLink = attrs .&. win32_fILE_ATTRIBUTE_REPARSE_POINT /= 0
    isDir  = attrs .&. Win32.fILE_ATTRIBUTE_DIRECTORY /= 0
    attrs  = Win32.bhfiFileAttributes info

fileSizeFromMetadata :: Metadata -> Integer
fileSizeFromMetadata = fromIntegral . Win32.bhfiSize

accessTimeFromMetadata :: Metadata -> UTCTime
accessTimeFromMetadata =
  posixSecondsToUTCTime . windowsToPosixTime . Win32.bhfiLastAccessTime

modificationTimeFromMetadata :: Metadata -> UTCTime
modificationTimeFromMetadata =
  posixSecondsToUTCTime . windowsToPosixTime . Win32.bhfiLastWriteTime

-- | Difference between the Windows and POSIX epochs in units of 100ns.
windowsPosixEpochDifference :: Num a => a
windowsPosixEpochDifference = 116444736000000000

-- | Convert from Windows time to POSIX time.
windowsToPosixTime :: Win32.FILETIME -> POSIXTime
windowsToPosixTime (Win32.FILETIME t) =
  (fromIntegral t - windowsPosixEpochDifference) / 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 t = Win32.FILETIME $
  truncate (t * 10000000 + windowsPosixEpochDifference)

type Mode = Win32.FileAttributeOrFlag

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

hasWriteMode :: Mode -> Bool
hasWriteMode m = m .&. Win32.fILE_ATTRIBUTE_READONLY == 0

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

setFileMode :: FilePath -> Mode -> IO ()
setFileMode path mode =
  (`ioeSetFileName` path) `modifyIOError` do
    path' <- toNormalisedExtendedLengthPath <$> prependCurrentDirectory 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 :: FilePath -> Mode -> IO ()
setFilePermissions path m = do
  m' <- modeFromMetadata <$> getFileMetadata path
  setFileMode path ((m' .&. complement Win32.fILE_ATTRIBUTE_READONLY) .|.
                    (m  .&. Win32.fILE_ATTRIBUTE_READONLY))

getAccessPermissions :: FilePath -> IO Permissions
getAccessPermissions path = do
  m <- getFileMetadata path
  let isDir = fileTypeIsDirectory (fileTypeFromMetadata m)
  let w = hasWriteMode (modeFromMetadata m)
  let x = (toLower <$> takeExtension path)
          `elem` [".bat", ".cmd", ".com", ".exe"]
  return Permissions
         { readable   = True
         , writable   = w
         , executable = x && not isDir
         , searchable = isDir
         }

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


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