Win32-junction-point 0.1 → 0.2
raw patch · 4 files changed
+423/−403 lines, 4 filesdep +Win32-errorsdep ~Win32dep ~basedep ~text
Dependencies added: Win32-errors
Dependency ranges changed: Win32, base, text
Files
- ChangeLog +12/−0
- System/Win32/JunctionPoint.hs +336/−333
- Win32-junction-point.cabal +59/−70
- include/windows_cconv.h +16/−0
+ ChangeLog view
@@ -0,0 +1,12 @@+## Changes in 0.2 + +* Depend on Win32-errors for error handling. +* More strict package dependencies + +## Changes in 0.1 + +* 64-bit GHC is now supported. +* Update cabal file to build on recent versions of GHC. +* An internal foreign import is now being called with the "safe" option. +* bug fixes. The deleteJunctionPoint function was failing to delete junction + points in many cases.
System/Win32/JunctionPoint.hs view
@@ -1,333 +1,336 @@-{-# LANGUAGE CPP #-}--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)---- Macro taken from winioctl.h--- #define CTL_CODE( DeviceType, Function, Method, Access) ( \--- (DWORD) ((DeviceType) << 16 | ((Access) << 14) | ((Function) << 2) \--- | (Method))-cTL_CODE :: DWORD -> DWORD -> DWORD -> DWORD -> DWORD-cTL_CODE d f m a = d `shift` 16 .|. a `shift` 14 .|. f `shift` 2 .|. m---- taken from winioctl.h-fILE_DEVICE_FILE_SYSTEM :: DWORD-fILE_DEVICE_FILE_SYSTEM = 0x00000009---- taken from winioctl.h-mETHOD_BUFFERED :: DWORD-mETHOD_BUFFERED = 0---- taken from winioctl.h-fILE_ANY_ACCESS, fILE_SPECIAL_ACCESS :: DWORD-fILE_ANY_ACCESS = 0-fILE_SPECIAL_ACCESS = 0---- taken from winioctl.h-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----taken from MSDN's OpenFileById documentation-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---- The first 3 fields of TMN_REPARSE_DATA_BUFFER are considered the--- header. This is used in setReparsePoint.-tMN_REPARSE_DATA_BUFFER_HEADER_SIZE :: DWORD-tMN_REPARSE_DATA_BUFFER_HEADER_SIZE = 8---- I've seen this defined as FIELD_OFFSET(REPARSE_GUID_DATA_BUFFER, GenericReparseBuffer)--- All the struct members up to the genericreparsebuffer add up to 24. I'm guessing that--- the size-1 byte array does not add to this count.-rEPARSE_GUID_DATA_BUFFER_HEADER_SIZE :: DWORD-rEPARSE_GUID_DATA_BUFFER_HEADER_SIZE = 24---- C structure. This is not documented in current versions of the--- Windows SDK.---- struct TMN_REPARSE_DATA_BUFFER--- {--- DWORD ReparseTag;--- WORD ReparseDataLength;--- WORD Reserved;--- WORD SubstituteNameOffset;--- WORD SubstituteNameLength;--- WORD PrintNameOffset;--- WORD PrintNameLength;--- WCHAR PathBuffer[1];--- };--data TMN_REPARSE_DATA_BUFFER = TMN_REPARSE_DATA_BUFFER- { _reparseTag :: !DWORD- -- Bytes in addition to first 8. This will be 12 + length of _pathBuffer- , _reparseDataLength :: !WORD- , _reserved :: !WORD- , _substituteNameOffset :: !WORD- , _substituteNameLength :: !WORD- , _printNameOffset :: !WORD- , _printNameLength :: !WORD- -- The C struct indicates a single-element array.- -- Actually, we need to allocate enough memory to- -- hold a string here.- , _pathBuffer :: !(Ptr CWchar)- }--instance Storable TMN_REPARSE_DATA_BUFFER where- -- Storable does not allow the pokes of different sizes, so we're just- -- allocating the maximum size Microsoft documents.- sizeOf _ = mAXIMUM_REPARSE_DATA_BUFFER_SIZE- alignment _ = 1 -- no alignment? I don't know what this means.- 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)---- This data structure is almost identical to TMN_REPARSE_DATA_BUFFER, but the--- meaning of fields differ. Microsoft documents this structure. It is--- used for querying existing reparse points.-data REPARSE_GUID_DATA_BUFFER = REPARSE_GUID_DATA_BUFFER- { _rgdb_ReparseTag :: DWORD- -- MS specifies an odd structure, but a GUID is really just a 128-bit- -- value.- , _rgdb_GUID1 :: !DWORD- , _rgdb_GUID2 :: !DWORD- , _rgdb_GUID3 :: !DWORD- , _rgdb_GUID4 :: !DWORD- -- The C struct indicates a single-element array.- -- Actually, we need to allocate enough memory to- -- hold a string here.- , _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- -- reserved WORD at byte 6- _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- -- must be empty when deleting a junction point- , _rgdb_DataBuffer = bx- }- f prgdb---- | Create a junction point between two folders on the same filesystem.------ 'mountDir' should be the full file path to an empty folder. This--- folder should be on a local filesystem.------ 'destDir' should be the full file path to the junction point's target. The--- target must be a folder on the same filesystem as its source. The path--- should also be preceeded by \"\\??\\\". This indicates to Windows not to try--- validating the path before using it.------ >>> createJunctionPoint "c:\\Windows\\System32" "\\??\\c:\\System32"-createJunctionPoint :: Text -- ^ mountDir- -> Text -- ^ destDir- -> IO ()-createJunctionPoint mountDir destDir =- withTMN_REPARSE_DATA_BUFFER destDir $ \rdb ->- bracket (openReparseHandle mountDir) closeHandle $ \handle ->- setReparsePoint handle rdb---- | This "Deletes" the junction point at the supplied path. On success an--- empty folder will be left in its place.-deleteJunctionPoint :: Text -> IO ()-deleteJunctionPoint dir =- bracket (openReparseHandle dir) closeHandle $ \handle -> do- deleteReparsePoint handle---- | Discover the target of a junction point at the supplied path. An--- exception will be raised if the target is either invalid or not a junction--- point. The returned path will be prefixed by \"\\??\\\".-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- --not sure how to call IsReparseTagValid.- rdb <- peek pRdb- fromPtr0 $ (_pathBuffer rdb)---- NTFS junction points are implemented as reparse points. Reparse points are--- extra tagged information attached to filesystem objects. It is up to--- application software such as the Windows Shell to detect the presence of--- reparse points and act approprietly.--- --- There are many types of reparse points. For the internal purposes of--- this library I am pretending that junction points are the only kind of--- reparse point.-setReparsePoint :: HANDLE -> Ptr TMN_REPARSE_DATA_BUFFER -> IO ()-setReparsePoint handle pRdb =- -- we don't care about bytesReturned- 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' will remove a reparse point pointed to by the--- argument. An exception will be raised if the argument does not point to an--- open reparse point, or possibly if the user does not have write attribute--- permissions to the object.-deleteReparsePoint :: HANDLE -> IO ()-deleteReparsePoint handle =- -- When deleting reparse points the destination does not matter.- -- msdn docs refer to REPARSE_GUID_DATA_BUFFER for this instead.- 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---- Open a reparse point attached to the supplied folder. An exception will be--- raised if the target does not exist, the user does not have read--- permissions to it, or the target does not have a reparse point attached.-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---- Low-level filesystem manipulation function. Check documentation in the MSDN--- library.-deviceIoControl :: HANDLE -> DWORD -> Maybe LPVOID -> DWORD -> Maybe LPVOID- -> DWORD -> Maybe LPDWORD -> Maybe LPOVERLAPPED -> IO ()-deviceIoControl hDevice dwIoControlCode lpInBuffer nInBufferSize- lpOutBuffer nOutBufferSize lpBytesReturned lpOverlapped =- failIfFalse_ (unwords [ "DeviceIoControl", show hDevice- , show dwIoControlCode]) $- c_DeviceIoControl hDevice dwIoControlCode- (maybe nullPtr id lpInBuffer) nInBufferSize- (maybe nullPtr id lpOutBuffer) nOutBufferSize- (maybe nullPtr id lpBytesReturned)- (maybe nullPtr id lpOverlapped)--#ifdef WIN64-foreign import "windows.h DeviceIoControl"-#else-foreign import stdcall "windows.h DeviceIoControl"-#endif- 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 =- -- simply converting Text to a name does not add a null character- useAsPtr0 name $ \ c_name ->- failIf (==iNVALID_HANDLE_VALUE) (unwords ["CreateFile", show name]) $- c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h)---- | useAsPtr returns a length and byte buffer, but all the win32 functions--- rely on null termination.-useAsPtr0 :: Text -> (Ptr CWchar -> IO a) -> IO a-useAsPtr0 t f = useAsPtr (T.snoc t (chr 0x0)) $ \ str _ -> f (castPtr str)---- This traverses the string twice. Is there a faster way?-fromPtr0 :: Ptr CWchar -> IO Text-fromPtr0 ptr = do- -- length in 16-bit words.- len <- lengthArray0 0x0000 ptr'- -- no loss of precision here. I16 is a newtype wrapper around Int.- fromPtr ptr' $ fromIntegral len- where- ptr' :: Ptr Word16- ptr' = castPtr ptr+{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +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" + +-- Macro taken from winioctl.h +-- #define CTL_CODE( DeviceType, Function, Method, Access) ( \ +-- (DWORD) ((DeviceType) << 16 | ((Access) << 14) | ((Function) << 2) \ +-- | (Method)) +cTL_CODE :: DWORD -> DWORD -> DWORD -> DWORD -> DWORD +cTL_CODE d f m a = d `shift` 16 .|. a `shift` 14 .|. f `shift` 2 .|. m + +-- taken from winioctl.h +fILE_DEVICE_FILE_SYSTEM :: DWORD +fILE_DEVICE_FILE_SYSTEM = 0x00000009 + +-- taken from winioctl.h +mETHOD_BUFFERED :: DWORD +mETHOD_BUFFERED = 0 + +-- taken from winioctl.h +fILE_ANY_ACCESS, fILE_SPECIAL_ACCESS :: DWORD +fILE_ANY_ACCESS = 0 +fILE_SPECIAL_ACCESS = 0 + +-- taken from winioctl.h +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 + +--taken from MSDN's OpenFileById documentation +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 + +-- The first 3 fields of TMN_REPARSE_DATA_BUFFER are considered the +-- header. This is used in setReparsePoint. +tMN_REPARSE_DATA_BUFFER_HEADER_SIZE :: DWORD +tMN_REPARSE_DATA_BUFFER_HEADER_SIZE = 8 + +-- I've seen this defined as FIELD_OFFSET(REPARSE_GUID_DATA_BUFFER, GenericReparseBuffer) +-- All the struct members up to the genericreparsebuffer add up to 24. I'm guessing that +-- the size-1 byte array does not add to this count. +rEPARSE_GUID_DATA_BUFFER_HEADER_SIZE :: DWORD +rEPARSE_GUID_DATA_BUFFER_HEADER_SIZE = 24 + +-- C structure. This is not documented in current versions of the +-- Windows SDK. + +-- struct TMN_REPARSE_DATA_BUFFER +-- { +-- DWORD ReparseTag; +-- WORD ReparseDataLength; +-- WORD Reserved; +-- WORD SubstituteNameOffset; +-- WORD SubstituteNameLength; +-- WORD PrintNameOffset; +-- WORD PrintNameLength; +-- WCHAR PathBuffer[1]; +-- }; + +data TMN_REPARSE_DATA_BUFFER = TMN_REPARSE_DATA_BUFFER + { _reparseTag :: !DWORD + -- Bytes in addition to first 8. This will be 12 + length of _pathBuffer + , _reparseDataLength :: !WORD + , _reserved :: !WORD + , _substituteNameOffset :: !WORD + , _substituteNameLength :: !WORD + , _printNameOffset :: !WORD + , _printNameLength :: !WORD + -- The C struct indicates a single-element array. + -- Actually, we need to allocate enough memory to + -- hold a string here. + , _pathBuffer :: !(Ptr CWchar) + } + +instance Storable TMN_REPARSE_DATA_BUFFER where + -- Storable does not allow the pokes of different sizes, so we're just + -- allocating the maximum size Microsoft documents. + sizeOf _ = mAXIMUM_REPARSE_DATA_BUFFER_SIZE + alignment _ = 1 -- no alignment? I don't know what this means. + 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) + +-- This data structure is almost identical to TMN_REPARSE_DATA_BUFFER, but the +-- meaning of fields differ. Microsoft documents this structure. It is +-- used for querying existing reparse points. +data REPARSE_GUID_DATA_BUFFER = REPARSE_GUID_DATA_BUFFER + { _rgdb_ReparseTag :: DWORD + -- MS specifies an odd structure, but a GUID is really just a 128-bit + -- value. + , _rgdb_GUID1 :: !DWORD + , _rgdb_GUID2 :: !DWORD + , _rgdb_GUID3 :: !DWORD + , _rgdb_GUID4 :: !DWORD + -- The C struct indicates a single-element array. + -- Actually, we need to allocate enough memory to + -- hold a string here. + , _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 + -- reserved WORD at byte 6 + _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 + -- must be empty when deleting a junction point + , _rgdb_DataBuffer = bx + } + f prgdb + +-- | Create a junction point between two folders on the same filesystem. +-- +-- 'mountDir' should be the full file path to an empty folder. This +-- folder should be on a local filesystem. +-- +-- 'destDir' should be the full file path to the junction point's target. The +-- target must be a folder on the same filesystem as its source. The path +-- should also be preceeded by \"\\??\\\". This indicates to Windows not to try +-- validating the path before using it. +-- +-- >>> createJunctionPoint "c:\\Windows\\System32" "\\??\\c:\\System32" +createJunctionPoint :: Text -- ^ mountDir + -> Text -- ^ destDir + -> IO () +createJunctionPoint mountDir destDir = + withTMN_REPARSE_DATA_BUFFER destDir $ \rdb -> + bracket (openReparseHandle mountDir) closeHandle $ \handle -> + setReparsePoint handle rdb + +-- | This "Deletes" the junction point at the supplied path. An +-- empty folder will be left in its place on success. A 'Win32Exception' +-- exception will be thrown in the event of an error condition. +deleteJunctionPoint :: Text -> IO () +deleteJunctionPoint dir = + bracket (openReparseHandle dir) closeHandle $ \handle -> do + deleteReparsePoint handle + +-- | Discover the target of a junction point at the supplied path. A +-- 'Win32Exception' exception will be thrown if the target is either invalid +-- or not a junction point. The returned path will be prefixed by \"\\??\\\". +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 + --not sure how to call IsReparseTagValid. + rdb <- peek pRdb + fromPtr0 $ (_pathBuffer rdb) + +-- NTFS junction points are implemented as reparse points. Reparse points are +-- extra tagged information attached to filesystem objects. It is up to +-- application software such as the Windows Shell to detect the presence of +-- reparse points and act approprietly. +-- +-- There are many types of reparse points. For the internal purposes of +-- this library I am pretending that junction points are the only kind of +-- reparse point. +setReparsePoint :: HANDLE -> Ptr TMN_REPARSE_DATA_BUFFER -> IO () +setReparsePoint handle pRdb = + -- we don't care about bytesReturned + 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' will remove a reparse point pointed to by the +-- argument. An exception will be raised if the argument does not point to an +-- open reparse point, or possibly if the user does not have write attribute +-- permissions to the object. +deleteReparsePoint :: HANDLE -> IO () +deleteReparsePoint handle = + -- When deleting reparse points the destination does not matter. + -- msdn docs refer to REPARSE_GUID_DATA_BUFFER for this instead. + 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 + +-- Open a reparse point attached to the supplied folder. A `Win32Error` exception +-- will be thrown if the target does not exist, the user does not have read +-- permissions to it, or the target does not have a reparse point attached. +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 + +-- Low-level filesystem manipulation function. Check documentation in the MSDN +-- library. +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 + +-- | Check MSDN documentation for what this action does. +createFile :: Text -> AccessMode -> ShareMode -> Maybe LPSECURITY_ATTRIBUTES + -> CreateMode -> FileAttributeOrFlag -> Maybe HANDLE -> IO HANDLE +createFile name access share mb_attr mode flag mb_h = + -- simply converting Text to a name does not add a null character + useAsPtr0 name $ \ c_name -> + failIf (== iNVALID_HANDLE_VALUE) "CreateFile" $ + c_CreateFile c_name access share (maybePtr mb_attr) mode flag (maybePtr mb_h) + +-- | useAsPtr returns a length and byte buffer, but all the win32 functions +-- rely on null termination. +useAsPtr0 :: Text -> (Ptr CWchar -> IO a) -> IO a +useAsPtr0 t f = useAsPtr (T.snoc t (chr 0x0)) $ \ str _ -> f (castPtr str) + +-- This traverses the string twice. Is there a faster way? +fromPtr0 :: Ptr CWchar -> IO Text +fromPtr0 ptr = do + -- length in 16-bit words. + len <- lengthArray0 0x0000 ptr' + -- no loss of precision here. I16 is a newtype wrapper around Int. + fromPtr ptr' $ fromIntegral len + where + ptr' :: Ptr Word16 + ptr' = castPtr ptr
Win32-junction-point.cabal view
@@ -1,70 +1,59 @@-Name: Win32-junction-point-Version: 0.1-Synopsis: Support for manipulating NTFS junction points.-Description:- This package provides the ability to manipulate NTFS junction points as- supported by Windows 2000 and above. Junction points, along with NTFS hard- links and NTFS symbolic links, are a type of symbolic link that can be made- between folders existing on the same filesystem. Please read Microsoft- KB205524 [1] for more information on junction points.- .- Junction points have always been left undocumented in the Win32 SDK. The- Windows 2000 Resource Kit came with a command-line utility named linkd.exe- to work with them. Later, Mark Russinovich of SysInternals distributed a- replacement utility named Junction [2] which accomplished the same thing.- .- This source code is based on an article [3] and C++ library [4] written by- Mike Nordell at codeproject.com.- .- It is against Microsoft's recommendation to make use of undocumented API- features. Use this library at your own risk.- .- Release Notes:- .- Changes in 0.1- .- * 64-bit GHC is now supported.- .- * Update cabal file to build on recent versions of GHC.- .- * An internal foreign import is now being called with the "safe" option.- .- * bug fixes. The deleteJunctionPoint function was failing to delete junction- points in many cases.- .- (1) <http://support.microsoft.com/?kbid=205524>- .- (2) <http://technet.microsoft.com/en-us/sysinternals/bb896768>- .- (3) <http://www.codeproject.com/script/Articles/ViewDownloads.aspx?aid=194>- .- (4) <http://www.codeproject.com/KB/winsdk/junctionpoints.aspx>-License: BSD3-License-file: LICENSE-Author: Michael Steele-Maintainer: mikesteele81@gmail.com-Copyright: Copyright (c) 2011-2013, Michael Steele. Copyright (c) 2000, Mikael Nordell-Category: System-Build-type: Simple-Cabal-version: >=1.14-Homepage: http://github.com/mikesteele81/Win32-junction-point-bug-reports: http://github.com/mikesteele81/win32-junction-point/issues--Stability: experimental-tested-with: GHC==7.4.2, GHC==7.6.2--source-repository head- type: git- location: git://github.com/mikesteele81/win32-junction-point.git--Library- default-language: Haskell2010- Exposed-modules: System.Win32.JunctionPoint-- Build-depends: base >= 4.0 && < 5- , text- , Win32- ghc-options: -funbox-strict-fields -Wall- if arch(x86_64)- cpp-options: -DWIN64-+Name: Win32-junction-point +Version: 0.2 +Synopsis: Support for manipulating NTFS junction points. +Description: + This package provides the ability to manipulate NTFS junction points as + supported by Windows 2000 and above. Junction points, along with NTFS hard + links and NTFS symbolic links, are a type of symbolic link that can be made + between folders existing on the same filesystem. Please read Microsoft + KB205524 [1] for more information on junction points. + . + Junction points have always been left undocumented in the Win32 SDK. The + Windows 2000 Resource Kit came with a command-line utility named linkd.exe + to work with them. Later, Mark Russinovich of SysInternals distributed a + replacement utility named Junction [2] which accomplished the same thing. + . + This source code is based on an article [3] and C++ library [4] written by + Mike Nordell at codeproject.com. + . + It is against Microsoft's recommendation to make use of undocumented API + features. Use this library at your own risk. + . + (1) <http://support.microsoft.com/?kbid=205524> + . + (2) <http://technet.microsoft.com/en-us/sysinternals/bb896768> + . + (3) <http://www.codeproject.com/script/Articles/ViewDownloads.aspx?aid=194> + . + (4) <http://www.codeproject.com/KB/winsdk/junctionpoints.aspx> +License: BSD3 +License-file: LICENSE +Author: Michael Steele +Maintainer: mikesteele81@gmail.com +Copyright: Copyright (c) 2011-2014, Michael Steele. Copyright (c) 2000, Mikael Nordell +Category: System +Build-type: Simple +Cabal-version: >=1.16 +Homepage: http://github.com/mikesteele81/Win32-junction-point +bug-reports: http://github.com/mikesteele81/win32-junction-point/issues +Stability: experimental +tested-with: GHC==7.8.2 +extra-source-files: + include/windows_cconv.h + ChangeLog + +source-repository head + type: git + location: git://github.com/mikesteele81/win32-junction-point.git + +Library + default-language: Haskell2010 + ghc-options: -Wall -funbox-strict-fields + cc-options: -fno-strict-aliasing + Exposed-modules: System.Win32.JunctionPoint + + Build-depends: base >= 4.0 && < 4.8 + , text >= 0.8 && < 1.2 + , Win32 >= 2.0 && < 2.4 + , Win32-errors >= 0.2 && < 0.3 + include-dirs: include
+ include/windows_cconv.h view
@@ -0,0 +1,16 @@+/* Taken from Win32. 64-bit Windows uses the 'ccall' calling convention + instead of 'stdcall' +*/ + +#ifndef __WINDOWS_CCONV_H +#define __WINDOWS_CCONV_H + +#if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +#elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +#else +# error Unknown mingw32 arch +#endif + +#endif