SymbolicLink.hs

{-# LANGUAGE CPP #-}
{- |
   Module      :  System.Win32.SymbolicLink
   Copyright   :  2012 shelarcy
   License     :  BSD-style

   Maintainer  :  shelarcy@gmail.com
   Stability   :  Provisional
   Portability :  Non-portable (Win32 API)

   Handling symbolic link using Win32 API. [Vista of later and desktop app only]

   Note: You should worry about UAC (User Account Control) when use this module function in your application:

     * require to use 'Run As Administrator' to run your application.

     * or modify your application's manifect file to add
       \<requestedExecutionLevel level='requireAdministrator' uiAccess='false'/\>.
-}
module System.Win32.SymbolicLink
  ( module System.Win32.SymbolicLink
  ) where
import Foreign.Ptr                  ( FunPtr )
import System.Win32.DLL.LoadFunction
import System.Win32.Error ( failIfFalseWithRetry_ )
import System.Win32.Types


-- | createSymbolicLink* doesn't check that file is exist or not.
createSymbolicLink :: FilePath -> FilePath -> SymbolicLinkFlags -> IO ()
createSymbolicLink = flip createSymbolicLink'

createSymbolicLinkFile :: FilePath -> FilePath -> IO ()
createSymbolicLinkFile src target = createSymbolicLink' target src sYMBOLIC_LINK_FLAG_FILE

createSymbolicLinkDirectory :: FilePath -> FilePath -> IO ()
createSymbolicLinkDirectory src target = createSymbolicLink' target src sYMBOLIC_LINK_FLAG_DIRECTORY

-- portable version
type SymbolicLinkFlags = DWORD
sYMBOLIC_LINK_FLAG_FILE, sYMBOLIC_LINK_FLAG_DIRECTORY :: SymbolicLinkFlags
sYMBOLIC_LINK_FLAG_FILE = 0x0
sYMBOLIC_LINK_FLAG_DIRECTORY = 0x1

-- portable version
createSymbolicLink' :: String -> String -> SymbolicLinkFlags -> IO ()
createSymbolicLink' target src flag =
  withLoadSystemFunction "Kernel32.dll" "CreateSymbolicLinkW" $ \c_CreateSymbolicLink ->
    withTString target $ \c_target ->
      withTString src  $ \c_src ->
        failIfFalseWithRetry_ (unwords ["CreateSymbolicLink",show target,show src]) $
          convCreateSymbolicLink c_CreateSymbolicLink c_target c_src flag

foreign import WINDOWS_CCONV unsafe "dynamic" convCreateSymbolicLink ::
   FunPtr (LPTSTR -> LPTSTR -> SymbolicLinkFlags -> IO BOOL)
   -> (LPTSTR -> LPTSTR -> SymbolicLinkFlags -> IO BOOL)
{-
-- non portable version.
createSymbolicLink' :: String -> String -> SymbolicLinkFlags -> IO ()
createSymbolicLink' target src flag = do
    withTString target $ \c_target ->
      withTString src  $ \c_src ->
        failIfFalseWithRetry_ (unwords ["CreateSymbolicLink",show target,show src]) $
          c_CreateSymbolicLink c_target c_src flag

{enum SymbolicLinkFlags,
 , sYMBOLIC_LINK_FLAG_FILE      = SYMBOLIC_LINK_FLAG_FILE
 , sYMBOLIC_LINK_FLAG_DIRECTORY = SYMBOLIC_LINK_FLAG_DIRECTORY
 }

foreign import WINDOWS_CCONV unsafe "windows.h CreateSymbolicLinkW"
  c_CreateSymbolicLink :: LPTSTR -> LPTSTR -> SymbolicLinkFlags -> IO BOOL
-}