module System.Win32.JunctionPoint
( createJunctionPoint
, deleteJunctionPoint
, getJunctionPointInfo
) where
import Control.Exception (bracket)
import Data.Bits
import Data.Char (chr)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Foreign
import Foreign
import Foreign.C
import System.Win32 hiding (createFile, failIf, failIfFalse_)
import System.Win32.Error
import System.Win32.Error.Foreign
#include "windows_cconv.h"
cTL_CODE :: DWORD -> DWORD -> DWORD -> DWORD -> DWORD
cTL_CODE d f m a = d `shift` 16 .|. a `shift` 14 .|. f `shift` 2 .|. m
fILE_DEVICE_FILE_SYSTEM :: DWORD
fILE_DEVICE_FILE_SYSTEM = 0x00000009
mETHOD_BUFFERED :: DWORD
mETHOD_BUFFERED = 0
fILE_ANY_ACCESS, fILE_SPECIAL_ACCESS :: DWORD
fILE_ANY_ACCESS = 0
fILE_SPECIAL_ACCESS = 0
fSCTL_SET_REPARSE_POINT :: DWORD
fSCTL_SET_REPARSE_POINT = cTL_CODE fILE_DEVICE_FILE_SYSTEM 41
mETHOD_BUFFERED fILE_SPECIAL_ACCESS
fSCTL_GET_REPARSE_POINT :: DWORD
fSCTL_GET_REPARSE_POINT = cTL_CODE fILE_DEVICE_FILE_SYSTEM 42
mETHOD_BUFFERED fILE_ANY_ACCESS
fSCTL_DELETE_REPARSE_POINT :: DWORD
fSCTL_DELETE_REPARSE_POINT = cTL_CODE fILE_DEVICE_FILE_SYSTEM 43
mETHOD_BUFFERED fILE_SPECIAL_ACCESS
iO_REPARSE_TAG_MOUNT_POINT :: DWORD
iO_REPARSE_TAG_MOUNT_POINT = 0xA0000003
fILE_FLAG_OPEN_REPARSE_POINT :: DWORD
fILE_FLAG_OPEN_REPARSE_POINT = 0x00200000
mAXIMUM_REPARSE_DATA_BUFFER_SIZE :: Int
mAXIMUM_REPARSE_DATA_BUFFER_SIZE = 16 * 1024
tMN_REPARSE_DATA_BUFFER_HEADER_SIZE :: DWORD
tMN_REPARSE_DATA_BUFFER_HEADER_SIZE = 8
rEPARSE_GUID_DATA_BUFFER_HEADER_SIZE :: DWORD
rEPARSE_GUID_DATA_BUFFER_HEADER_SIZE = 24
data TMN_REPARSE_DATA_BUFFER = TMN_REPARSE_DATA_BUFFER
{ _reparseTag :: !DWORD
, _reparseDataLength :: !WORD
, _reserved :: !WORD
, _substituteNameOffset :: !WORD
, _substituteNameLength :: !WORD
, _printNameOffset :: !WORD
, _printNameLength :: !WORD
, _pathBuffer :: !(Ptr CWchar)
}
instance Storable TMN_REPARSE_DATA_BUFFER where
sizeOf _ = mAXIMUM_REPARSE_DATA_BUFFER_SIZE
alignment _ = 1
peek ptr = do
reparseTag <- peek . castPtr $ ptr
reparseDataLength <- castPtr ptr `peekByteOff` 4
reserved <- castPtr ptr `peekByteOff` 6
substituteNameOffset <- castPtr ptr `peekByteOff` 8
substituteNameLength <- castPtr ptr `peekByteOff` 10
printNameOffset <- castPtr ptr `peekByteOff` 12
printNameLength <- castPtr ptr `peekByteOff` 14
let pathBuffer = castPtr ptr `plusPtr` 16
return $ TMN_REPARSE_DATA_BUFFER reparseTag reparseDataLength reserved
substituteNameOffset substituteNameLength printNameOffset
printNameLength pathBuffer
poke ptr rdb = do
castPtr ptr `poke` _reparseTag rdb
castPtr ptr `pokeByteOff` 4 $ _reparseDataLength rdb
castPtr ptr `pokeByteOff` 6 $ _reserved rdb
castPtr ptr `pokeByteOff` 8 $ _substituteNameOffset rdb
castPtr ptr `pokeByteOff` 10 $ _substituteNameLength rdb
castPtr ptr `pokeByteOff` 12 $ _printNameOffset rdb
castPtr ptr `pokeByteOff` 14 $ _printNameLength rdb
strLen <- lengthArray0 0 $ _pathBuffer rdb
copyArray (ptr `plusPtr` 16) (_pathBuffer rdb) (strLen + 1)
data REPARSE_GUID_DATA_BUFFER = REPARSE_GUID_DATA_BUFFER
{ _rgdb_ReparseTag :: DWORD
, _rgdb_GUID1 :: !DWORD
, _rgdb_GUID2 :: !DWORD
, _rgdb_GUID3 :: !DWORD
, _rgdb_GUID4 :: !DWORD
, _rgdb_DataBuffer :: [BYTE]
}
peekREPARSE_GUID_DATA_BUFFER :: Ptr REPARSE_GUID_DATA_BUFFER -> IO REPARSE_GUID_DATA_BUFFER
peekREPARSE_GUID_DATA_BUFFER ptr = do
_rgdb_ReparseTag <- peek . castPtr $ ptr
dataLength <- (castPtr ptr :: Ptr WORD) `peekByteOff` 4
_rgdb_GUID1 <- castPtr ptr `peekByteOff` 8
_rgdb_GUID2 <- castPtr ptr `peekByteOff` 12
_rgdb_GUID3 <- castPtr ptr `peekByteOff` 16
_rgdb_GUID4 <- castPtr ptr `peekByteOff` 20
dataBuffer <- peekArray dataLength (castPtr ptr `plusPtr` 24)
return $ REPARSE_GUID_DATA_BUFFER _rgdb_ReparseTag
_rgdb_GUID1 _rgdb_GUID2 _rgdb_GUID3 _rgdb_GUID4 dataBuffer
pokeREPARSE_GUID_DATA_BUFFER :: Ptr REPARSE_GUID_DATA_BUFFER -> REPARSE_GUID_DATA_BUFFER -> IO ()
pokeREPARSE_GUID_DATA_BUFFER ptr rdb = do
castPtr ptr `poke` _rgdb_ReparseTag rdb
castPtr ptr `pokeByteOff` 4 $ (fromIntegral dataLength :: WORD)
castPtr ptr `pokeByteOff` 8 $ _rgdb_GUID1 rdb
castPtr ptr `pokeByteOff` 12 $ _rgdb_GUID2 rdb
castPtr ptr `pokeByteOff` 16 $ _rgdb_GUID3 rdb
castPtr ptr `pokeByteOff` 20 $ _rgdb_GUID4 rdb
pokeArray (castPtr ptr `plusPtr` 24) $ _rgdb_DataBuffer rdb
where
dataLength = length $ _rgdb_DataBuffer rdb
withTMN_REPARSE_DATA_BUFFER :: Text
-> (Ptr TMN_REPARSE_DATA_BUFFER -> IO a) -> IO a
withTMN_REPARSE_DATA_BUFFER dst f =
useAsPtr0 dst $ \c_dst ->
with (TMN_REPARSE_DATA_BUFFER
{ _reparseTag = iO_REPARSE_TAG_MOUNT_POINT
, _reparseDataLength = dstLen + 12
, _reserved = 0
, _substituteNameOffset = 0
, _substituteNameLength = dstLen
, _printNameOffset = dstLen + 2
, _printNameLength = 0
, _pathBuffer = c_dst
}) f
where
dstLen = fromIntegral (T.length dst) * 2
withREPARSE_GUID_DATA_BUFFER :: [BYTE]
-> (Ptr REPARSE_GUID_DATA_BUFFER -> IO a) -> IO a
withREPARSE_GUID_DATA_BUFFER bx f =
allocaBytes (fromIntegral rEPARSE_GUID_DATA_BUFFER_HEADER_SIZE + length bx) $ \prgdb -> do
pokeREPARSE_GUID_DATA_BUFFER prgdb
$ REPARSE_GUID_DATA_BUFFER
{ _rgdb_ReparseTag = iO_REPARSE_TAG_MOUNT_POINT
, _rgdb_GUID1 = 0
, _rgdb_GUID2 = 0
, _rgdb_GUID3 = 0
, _rgdb_GUID4 = 0
, _rgdb_DataBuffer = bx
}
f prgdb
createJunctionPoint :: Text
-> Text
-> IO ()
createJunctionPoint mountDir destDir =
withTMN_REPARSE_DATA_BUFFER destDir $ \rdb ->
bracket (openReparseHandle mountDir) closeHandle $ \handle ->
setReparsePoint handle rdb
deleteJunctionPoint :: Text -> IO ()
deleteJunctionPoint dir =
bracket (openReparseHandle dir) closeHandle $ \handle -> do
deleteReparsePoint handle
getJunctionPointInfo :: Text -> IO Text
getJunctionPointInfo dir =
bracket (openReparseHandle dir) closeHandle $ \handle ->
with (0 :: DWORD) $ \bytesReturned ->
withTMN_REPARSE_DATA_BUFFER (T.pack "") $ \pRdb -> do
deviceIoControl handle fSCTL_GET_REPARSE_POINT Nothing 0
(Just $ castPtr pRdb)
(fromIntegral mAXIMUM_REPARSE_DATA_BUFFER_SIZE)
(Just bytesReturned) Nothing
rdb <- peek pRdb
fromPtr0 $ (_pathBuffer rdb)
setReparsePoint :: HANDLE -> Ptr TMN_REPARSE_DATA_BUFFER -> IO ()
setReparsePoint handle pRdb =
with (0 :: DWORD) $ \bytesReturned -> do
rdb <- peek pRdb
deviceIoControl handle fSCTL_SET_REPARSE_POINT
(Just $ castPtr pRdb)
(tMN_REPARSE_DATA_BUFFER_HEADER_SIZE +
(fromIntegral $ _reparseDataLength rdb))
Nothing 0 (Just bytesReturned) Nothing
deleteReparsePoint :: HANDLE -> IO ()
deleteReparsePoint handle =
withREPARSE_GUID_DATA_BUFFER [] $ \pRgdb ->
with (0 :: DWORD) $ \bytesReturned -> do
deviceIoControl handle fSCTL_DELETE_REPARSE_POINT
(Just $ castPtr pRgdb)
rEPARSE_GUID_DATA_BUFFER_HEADER_SIZE
Nothing 0 (Just bytesReturned) Nothing
openReparseHandle :: Text -> IO HANDLE
openReparseHandle path = createFile path (gENERIC_READ .|. gENERIC_WRITE)
fILE_SHARE_NONE Nothing oPEN_EXISTING
(fILE_FLAG_BACKUP_SEMANTICS .|. fILE_FLAG_OPEN_REPARSE_POINT)
Nothing
deviceIoControl :: HANDLE -> DWORD -> Maybe LPVOID -> DWORD -> Maybe LPVOID
-> DWORD -> Maybe LPDWORD -> Maybe LPOVERLAPPED -> IO ()
deviceIoControl hDevice dwIoControlCode lpInBuffer nInBufferSize
lpOutBuffer nOutBufferSize lpBytesReturned lpOverlapped =
failIfFalse_ "DeviceIoControl" $
c_DeviceIoControl hDevice dwIoControlCode
(maybe nullPtr id lpInBuffer) nInBufferSize
(maybe nullPtr id lpOutBuffer) nOutBufferSize
(maybe nullPtr id lpBytesReturned)
(maybe nullPtr id lpOverlapped)
foreign import WINDOWS_CCONV "windows.h DeviceIoControl"
c_DeviceIoControl :: HANDLE -> DWORD -> LPVOID -> DWORD -> LPVOID
-> DWORD -> LPDWORD -> LPOVERLAPPED -> IO Bool
createFile :: Text -> AccessMode -> ShareMode -> Maybe LPSECURITY_ATTRIBUTES
-> CreateMode -> FileAttributeOrFlag -> Maybe HANDLE -> IO HANDLE
createFile name access share mb_attr mode flag mb_h =
useAsPtr0 name $ \ c_name ->
failIf (== iNVALID_HANDLE_VALUE) "CreateFile" $
c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h)
useAsPtr0 :: Text -> (Ptr CWchar -> IO a) -> IO a
useAsPtr0 t f = useAsPtr (T.snoc t (chr 0x0)) $ \ str _ -> f (castPtr str)
fromPtr0 :: Ptr CWchar -> IO Text
fromPtr0 ptr = do
len <- lengthArray0 0x0000 ptr'
fromPtr ptr' $ fromIntegral len
where
ptr' :: Ptr Word16
ptr' = castPtr ptr