diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Piotr Latanowicz + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Piotr Latanowicz nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Win32-shortcut.cabal b/Win32-shortcut.cabal new file mode 100644 --- /dev/null +++ b/Win32-shortcut.cabal @@ -0,0 +1,38 @@ +name: Win32-shortcut +version: 0.0.1 +synopsis: Support for manipulating shortcuts (.lnk files) on Windows +description: + This package provides mechanism for reading and + writing Windows shortcuts a.k.a. shell links. + It uses COM library under the hood. +license: BSD3 +license-file: LICENSE +author: Piotr Latanowicz +maintainer: piotr.latanowicz@gmail.com +category: System +copyright: 2017 Piotr Latanowicz +Homepage: https://github.com/opasly-wieprz/Win32-shortcut +build-type: Simple +cabal-version: >=1.10 +stability: experimental +extra-source-files: + include/windows_cconv.h + +library + default-language: Haskell2010 + ghc-options: -Wall -funbox-strict-fields + cc-options: -fno-strict-aliasing + extra-libraries: ole32, uuid + exposed-modules: System.Win32.Shortcut + other-modules: System.Win32.Shortcut.Error, + System.Win32.Shortcut.Internal + hs-source-dirs: src + include-dirs: include + build-depends: base >= 4.9 && < 5, + Win32, + mtl, + th-utilities + +source-repository head + type: git + location: git://github.com/opasly-wieprz/Win32-shortcut.git diff --git a/include/windows_cconv.h b/include/windows_cconv.h new file mode 100644 --- /dev/null +++ b/include/windows_cconv.h @@ -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 diff --git a/src/System/Win32/Shortcut.hs b/src/System/Win32/Shortcut.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/Shortcut.hs @@ -0,0 +1,397 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} + +-- | +-- Working with @.lnk@ format should be a matter of serializing. +-- This library takes simpler approach, utilizing @Component Object Model@ +-- (@COM@) library. Even though @COM@ provides some means of serialization, +-- they cannot be used in a pure fashion - the library needs +-- to be initialized and some @COM@ functions still query the +-- system for data. For this reason this library sticks to 'IO'. +-- +-- Before calling 'writeShortcut' or 'readShortcut', @COM@ library +-- must be initialized with 'initialize'. +-- +-- Library does not support shortcut's @IDList@s, so creating or +-- reading links to devices or network connections is not possible. +-- +-- === Example +-- @ +-- import Control.Monad.Except +-- +-- main = print . runExceptT $ do +-- let link = empty { targetPath = "notepad.exe" } +-- +-- ExceptT initialize +-- ExceptT $ writeShortcut link "c:\\\\link.lnk" +-- ret <- ExceptT $ readShortcut "c:\\\\link.lnk" +-- liftIO $ uninitialize +-- +-- return ret +-- @ +-- @ +-- >>> main +-- Right (Shortcut {targetPath = "C:\\\\Windows\\\\system32\\\\notepad.exe", +-- arguments = "", workingDirectory = "", showCmd = ShowNormal, +-- description = "", iconLocation = ("",0), hotkey = 0}) +-- @ +module System.Win32.Shortcut ( + + Shortcut (..), + empty, + ShowCmd (..), + + -- * Basic operations + writeShortcut, + unsafeWriteShortcut, + readShortcut, + + -- * COM initialization + initialize, + uninitialize, + + -- * Errors + ShortcutError (..), + + -- ** File IO Errors + LoadError (..), + SaveError (..), + + -- ** Argument errors + PathError (..), + ArgumentsError (..), + WorkingDirectoryError (..), + DescriptionError (..), + IconLocationError (..), + + -- ** Other errors + CoCreateInstanceError (..), + CoInitializeError (..), + HRESULTError (..), + OrHRESULTError (..) +) +where + +import Control.Monad (when, void) +import Control.Monad.Cont (ContT (..)) +import Control.Monad.Except (ExceptT (..), withExceptT, runExceptT, throwError) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans (lift) +import Foreign (allocaArray) +import Foreign.C (peekCWString) + +import System.Win32.Shortcut.Error +import System.Win32.Shortcut.Internal + + +-- | Defines how a window will be opened when a link is executed. +data ShowCmd + = ShowNormal + -- ^ Start normally. + | ShowMaximized + -- ^ Start maximized. + | ShowMinimized + -- ^ Start minimized. + deriving (Show) + +fromShowCmd :: ShowCmd -> CInt +fromShowCmd = \case + ShowNormal -> sW_SHOWNORMAL + ShowMaximized -> sW_SHOWMAXIMIZED + ShowMinimized -> sW_SHOWMINNOACTIVE + +toShowCmd :: CInt -> ShowCmd +toShowCmd x + | x == sW_SHOWNORMAL = ShowNormal + | x == sW_SHOWMAXIMIZED = ShowMaximized + | x == sW_SHOWMINNOACTIVE = ShowMinimized + | otherwise = ShowNormal + + +-- | A shell link. +-- +-- It seems that @.lnk@ format permits up to 32767 +-- characters in text fields (259 for 'targetPath'), however +-- if 'workingDirectory', 'description' or 'iconLocation' is +-- longer then 259 characters @COM@ won't be able to read the +-- shortcut corectly ('readShortcut' will return faulty link without +-- raising any error, and @explorer.exe@ may not interpret it properly). +-- For this reason two write functions are provided. 'unsafeWriteShortcut' +-- will allow long fields and 'writeShortcut' which will raise +-- error if 'workingDirectory', 'description' or 'iconLocation' +-- is longer then 259 characters. +data Shortcut = Shortcut { + targetPath :: FilePath, + -- ^ Path to target. + arguments :: String, + -- ^ Arguments for target. + workingDirectory :: FilePath, + -- ^ Path to working directory. + showCmd :: ShowCmd, + description :: String, + iconLocation :: (FilePath, Int), + -- ^ Path to icon container (e.g. @.exe@, @.dll@, or @.ico@ file) + -- and icon index. + hotkey :: WORD + -- ^ The virtual key code is in the low-order byte, + -- and the modifier flags are in the high-order byte. + -- @'hotkey' == 0@ means no hotkey will be used. +} deriving (Show) + + +type Callee struct vtbl fun = vtbl -> VtblPtrFun struct fun + +newtype Caller struct vtbl = Call { + call :: forall fun . Callee struct vtbl fun -> fun +} + +makeMethodCaller + :: (Storable vtbl, Storable struct) + => (struct -> Ptr vtbl) + -> Ptr (Ptr struct) + -> IO (Caller struct vtbl) +makeMethodCaller getVtbl structPtrPtr = do + structPtr <- peek structPtrPtr + structVtbl <- peek structPtr >>= peek . getVtbl + return $ Call $ \getMtd -> getMtd structVtbl structPtr + + +type IShellLinkWCallee fun = Callee IShellLinkW IShellLinkWVtbl fun + +type IShellLinkWCaller = Caller IShellLinkW IShellLinkWVtbl + +ishQueryInterface' :: IShellLinkWCallee (REFIID -> Ptr (Ptr ()) -> IO HRESULT) +ishQueryInterface' = dynIshQueryInterface . ishQueryInterface + +getPath' :: IShellLinkWCallee (LPWSTR -> CInt -> Ptr WIN32_FIND_DATAW -> DWORD -> IO HRESULT) +getPath' = dynGetPath . getPath + +setPath' :: IShellLinkWCallee (LPCWSTR -> IO HRESULT) +setPath' = dynSetPath . setPath + +getArguments' :: IShellLinkWCallee (LPWSTR -> CInt -> IO HRESULT) +getArguments' = dynGetArguments . getArguments + +setArguments' :: IShellLinkWCallee (LPCWSTR -> IO HRESULT) +setArguments' = dynSetArguments . setArguments + +getWorkingDirectory' :: IShellLinkWCallee (LPWSTR -> CInt -> IO HRESULT) +getWorkingDirectory' = dynGetWorkingDirectory . getWorkingDirectory + +setWorkingDirectory' :: IShellLinkWCallee (LPCWSTR -> IO HRESULT) +setWorkingDirectory' = dynSetWorkingDirectory . setWorkingDirectory + +getShowCmd' :: IShellLinkWCallee (Ptr CInt -> IO HRESULT) +getShowCmd' = dynGetShowCmd . getShowCmd + +setShowCmd' :: IShellLinkWCallee (CInt -> IO HRESULT) +setShowCmd' = dynSetShowCmd . setShowCmd + +getDescription' :: IShellLinkWCallee (LPWSTR -> CInt -> IO HRESULT) +getDescription' = dynGetDescription . getDescription + +setDescription' :: IShellLinkWCallee (LPCWSTR -> IO HRESULT) +setDescription' = dynSetDescription . setDescription + +getHotkey' :: IShellLinkWCallee (Ptr WORD -> IO HRESULT) +getHotkey' = dynGetHotkey . getHotkey + +setHotkey' :: IShellLinkWCallee (WORD -> IO HRESULT) +setHotkey' = dynSetHotkey . setHotkey + +getIconLocation' :: IShellLinkWCallee (LPWSTR -> CInt -> Ptr CInt -> IO HRESULT) +getIconLocation' = dynGetIconLocation . getIconLocation + +setIconLocation' :: IShellLinkWCallee (LPCWSTR -> CInt -> IO HRESULT) +setIconLocation' = dynSetIconLocation . setIconLocation + +ishRelease' :: IShellLinkWCallee (IO ULONG) +ishRelease' = dynIshRelease . ishRelease + + +type IPersistFileCallee fun = Callee IPersistFile IPersistFileVtbl fun + +type IPersistFileCaller = Caller IPersistFile IPersistFileVtbl + +save' :: IPersistFileCallee (LPCOLESTR -> WINBOOL -> IO HRESULT) +save' = dynSave . save + +load' :: IPersistFileCallee (LPCOLESTR -> DWORD -> IO HRESULT) +load' = dynLoad . load + +ipRelease' :: IPersistFileCallee (IO ULONG) +ipRelease' = dynIpRelease . ipRelease + + +withCaller + :: (Storable struct, Storable vtbl) + => (Ptr (Ptr ()) -> IO HRESULT) + -> (struct -> Ptr vtbl) + -> Callee struct vtbl (IO ULONG) + -> ExceptT (OrHRESULTError CoCreateInstanceError) (ContT r IO) (Caller struct vtbl) +withCaller new getVtbl release = do + structPtr <- lift . ContT . with $ nullPtr + res <- liftIO $ new (castPtr structPtr) + case succeeded' toCoCreateInstanceError res of + Left err -> throwError err + Right _ -> lift . ContT $ \k -> do + caller <- makeMethodCaller getVtbl structPtr + ret <- k caller + void $ call caller release + return ret + +withIShellLinkCaller :: ExceptT (OrHRESULTError CoCreateInstanceError) (ContT r IO) IShellLinkWCaller +withIShellLinkCaller = + withCaller + (c_CoCreateInstance c_CLSID_ShellLink nullPtr cLSCTX_ALL c_IID_IShellLinkW) + ishlpVtbl + ishRelease' + +withIPersistFileCaller + :: IShellLinkWCaller + -> ExceptT (OrHRESULTError CoCreateInstanceError) (ContT r IO) IPersistFileCaller +withIPersistFileCaller shellLinkCaller = + withCaller + (call shellLinkCaller ishQueryInterface' c_IID_IPersistFile) + iplpVtbl + ipRelease' + + +-- Max length of a CString fields, including terminator +longFieldLength, shortFieldLength :: CInt +longFieldLength = 32768 +shortFieldLength = mAX_PATH + 1 -- does not apply to targetPath + + +-- | Create a shortcut under specified location. 'initialize' must be +-- called beforehand. 'targetPath' will be resolved with +-- respect to whatever is found in @PATH@ variable or desktop +-- if saved path is not absolute. +writeShortcut:: Shortcut -> FilePath -> IO (Either ShortcutError ()) +writeShortcut = writeShortcutGeneric True + +-- | Same as 'writeShortcut', but allows long 'description', +-- 'workingDirectory' and 'iconLocation' fields. @COM@ and @explorer.exe@ +-- may not interpret created link correctly. +unsafeWriteShortcut :: Shortcut -> FilePath -> IO (Either ShortcutError ()) +unsafeWriteShortcut = writeShortcutGeneric False + +writeShortcutGeneric :: Bool -> Shortcut -> FilePath -> IO (Either ShortcutError ()) +writeShortcutGeneric safeRead shortcut path = flip runContT return . runExceptT $ do + + let throwIfTooLong f maxLength err = when (length (f shortcut) >= fromIntegral maxLength) (throwError err) + throwIfTooLong' f = throwIfTooLong f (if safeRead then shortFieldLength else longFieldLength) in + do throwIfTooLong targetPath mAX_PATH (InvalidPath $ OtherError PathTooLong) + throwIfTooLong arguments longFieldLength (InvalidArguments $ OtherError ArgumentsTooLong) + + throwIfTooLong' workingDirectory (InvalidWorkingDirectory $ OtherError WorkingDirectoryTooLong) + throwIfTooLong' description (InvalidDescription $ OtherError DescriptionTooLong) + throwIfTooLong' (fst . iconLocation) (InvalidIconLocation $ OtherError IconLocationTooLong) + + shellLinkCaller <- withExceptT CreateIShellLinkInterfaceError withIShellLinkCaller + + withExcept' (Left . InvalidPath . HRESULTError) $ + call shellLinkCaller setPath' <$> ContT (withCWString $ targetPath shortcut) + + withExcept' (Left . InvalidArguments . HRESULTError) $ + call shellLinkCaller setArguments' <$> ContT (withCWString $ arguments shortcut) + + withExcept' (Left . InvalidWorkingDirectory . HRESULTError) $ + call shellLinkCaller setWorkingDirectory' <$> ContT (withCWString $ workingDirectory shortcut) + + withExcept' (Left . InvalidShowCmd) $ + call shellLinkCaller setShowCmd' <$> pure (fromShowCmd $ showCmd shortcut) + + withExcept' (Left . InvalidDescription . HRESULTError) $ + call shellLinkCaller setDescription' <$> ContT (withCWString $ description shortcut) + + let (iconLocation', iconIndex) = iconLocation shortcut + withExcept' (Left . InvalidIconLocation . HRESULTError) $ + call shellLinkCaller setIconLocation' <$> ContT (withCWString iconLocation') <*> pure (fromIntegral iconIndex) + + withExcept' (Left . InvalidHotkey) . pure $ + call shellLinkCaller setHotkey' (hotkey shortcut) + + iPersistFileCaller <- withExceptT CreateIPersistFileInterfaceError $ + withIPersistFileCaller shellLinkCaller + + withExcept' (overLeft SaveError . toSaveError) $ + call iPersistFileCaller save' <$> ContT (withCWString path) <*> pure tRUE + + +-- | Read a shortcut from the supplied location. 'initialize' must be +-- called beforehand. +readShortcut :: FilePath -> IO (Either ShortcutError Shortcut) +readShortcut path = flip runContT return . runExceptT $ do + + shellLinkCaller <- withExceptT CreateIShellLinkInterfaceError withIShellLinkCaller + + iPersistFileCaller <- withExceptT CreateIPersistFileInterfaceError $ + withIPersistFileCaller shellLinkCaller + + withExcept' (overLeft LoadError . toLoadError) $ + call iPersistFileCaller load' <$> ContT (withCWString path) <*> pure sTGM_READ + + pathPtr <- lift . ContT $ allocaArray (fromIntegral mAX_PATH) + withExcept' (overLeft InvalidPath . toPathError) . pure $ + call shellLinkCaller getPath' pathPtr mAX_PATH nullPtr sLGP_RAWPATH + + argumentsPtr <- lift . ContT $ allocaArray (fromIntegral longFieldLength) + withExcept' (Left . InvalidArguments . HRESULTError) . pure $ + call shellLinkCaller getArguments' argumentsPtr longFieldLength + + workingDirectoryPtr <- lift . ContT $ allocaArray (fromIntegral shortFieldLength) + withExcept' (Left . InvalidWorkingDirectory . HRESULTError) . pure $ + call shellLinkCaller getWorkingDirectory' workingDirectoryPtr shortFieldLength + + showCmdPtr <- lift . ContT $ with 0 + withExcept' (Left . InvalidShowCmd) . pure $ + call shellLinkCaller getShowCmd' showCmdPtr + + descriptionPtr <- lift . ContT $ allocaArray (fromIntegral shortFieldLength) + withExcept' (Left . InvalidDescription . HRESULTError) . pure $ + call shellLinkCaller getDescription' descriptionPtr shortFieldLength + + iconLocationPtr <- lift . ContT $ allocaArray (fromIntegral shortFieldLength) + iconIndexPtr <- lift . ContT $ with 0 + withExcept' (Left . InvalidIconLocation . HRESULTError) . pure $ + call shellLinkCaller getIconLocation' iconLocationPtr shortFieldLength iconIndexPtr + + hotkeyPtr <- lift . ContT $ with 0 + withExcept' (Left . InvalidHotkey) . pure $ + call shellLinkCaller getHotkey' hotkeyPtr + + liftIO $ + Shortcut <$> peekCWString pathPtr + <*> peekCWString argumentsPtr + <*> peekCWString workingDirectoryPtr + <*> (toShowCmd <$> peek showCmdPtr) + <*> peekCWString descriptionPtr + <*> ((,) <$> peekCWString iconLocationPtr + <*> (fromIntegral <$> peek iconIndexPtr)) + <*> peek hotkeyPtr + + +-- | Initialize @COM@ library for current thread. +-- Wraps +-- function. +initialize :: IO (Either ShortcutError ()) +initialize = succeeded' (overLeft InitializationError . toCoInitializeError) + <$> c_CoInitializeEx nullPtr cOINIT_MULTITHREADED + +-- | Uninitialize @COM@ library for current thread. +uninitialize :: IO () +uninitialize = c_CoUninitialize + + +-- | An empty link. All fields are set to empty/default values. +empty :: Shortcut +empty = Shortcut { + targetPath = "", + arguments = "", + workingDirectory = "", + showCmd = ShowNormal, + description = "", + iconLocation = ("", 0), + hotkey = 0 +} diff --git a/src/System/Win32/Shortcut/Error.hs b/src/System/Win32/Shortcut/Error.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/Shortcut/Error.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE LambdaCase #-} + +module System.Win32.Shortcut.Error +where + +import Control.Monad (join) +import Control.Monad.Except (ExceptT (..)) +import Control.Monad.Trans (MonadTrans, lift) + +import System.Win32.Shortcut.Internal + +-- | In @Win32 API@ 'HRESULT' is used to indicate error and warning +-- conditions. 'HRESULTError' wraps 'HRESULT' to give it some meaning. +data HRESULTError + = E_ABORT + -- ^ Operation aborted. + | E_ACCESSDENIED + -- ^ General access denied error. + | E_FAIL + -- ^ Unspecified failure. + | E_HANDLE + -- ^ Handle that is not valid. + | E_INVALIDARG + -- ^ One or more arguments are not valid. + | E_NOINTERFACE + -- ^ No such interface supported. + | E_NOTIMPL + -- ^ Not implemented. + | E_OUTOFMEMORY + -- ^ Failed to allocate necessary memory. + | E_POINTER + -- ^ Pointer that is not valid. + | E_UNEXPECTED + -- ^ Unexpected failure. + | HRESULTUnknown HRESULT + -- ^ Other, unknown 'HRESULT' value. + deriving (Show) + +succeeded :: HRESULT -> Either HRESULTError () +succeeded x + | x == s_OK = Right () + | x == e_ACCESSDENIED = Left E_ACCESSDENIED + | x == e_FAIL = Left E_FAIL + | x == e_HANDLE = Left E_HANDLE + | x == e_INVALIDARG = Left E_INVALIDARG + | x == e_NOINTERFACE = Left E_NOINTERFACE + | x == e_NOTIMPL = Left E_NOTIMPL + | x == e_OUTOFMEMORY = Left E_OUTOFMEMORY + | x == e_POINTER = Left E_POINTER + | x == e_UNEXPECTED = Left E_UNEXPECTED + | otherwise = Left (HRESULTUnknown x) + +succeeded' :: (HRESULTError -> Either e ()) -> HRESULT -> Either e () +succeeded' f = either f Right . succeeded + +withExcept' + :: (MonadTrans t, Monad (t m), Monad m) + => (HRESULTError -> Either e ()) + -> t m (m HRESULT) + -> ExceptT e (t m) () +withExcept' f = ExceptT . fmap (succeeded' f) . join . fmap lift + +overLeft :: (e1 -> e2) -> Either e1 a -> Either e2 a +overLeft f = either (Left . f) Right + + +-- | Some error that comes from 'HRESULT'. +data OrHRESULTError err + = OtherError err + -- ^ 'HRESULT' value was expected and fits @err@. + | HRESULTError HRESULTError + -- ^ 'HRESULT' did not fit @err@. + deriving (Show) + +-- | @COM@ cannot create specified interface. +data CoCreateInstanceError + = CCI_REGDB_E_CLASSNOTREG + -- ^ A specified class is not registered in the registration database. + -- Also can indicate that the type of server you requested + -- in the CLSCTX enumeration is not registered or the values + -- for the server types in the registry are corrupt. + | CCI_CLASS_E_NOAGGREGATION + -- ^ This class cannot be created as part of an aggregate. + | CCI_E_NOINTERFACE + -- ^ The specified class does not implement the requested interface, + -- or the controlling IUnknown does not expose the requested interface. + | CCI_E_POINTER + -- ^ The ppv parameter is NULL. + | CCI_CO_E_NOTINITIALIZED + -- ^ @COM@ library was not initialized. + deriving (Show) + +toCoCreateInstanceError :: HRESULTError -> Either (OrHRESULTError CoCreateInstanceError) () +toCoCreateInstanceError = Left . \case + HRESULTUnknown x + | x == -2147221164 -- 0x80040154 + -> OtherError CCI_REGDB_E_CLASSNOTREG + | x == -2147221232 -- 0x80040110 + -> OtherError CCI_CLASS_E_NOAGGREGATION + | x == -2147221008 -- 0x800401f0 + -> OtherError CCI_CO_E_NOTINITIALIZED + E_NOINTERFACE -> OtherError CCI_E_NOINTERFACE + E_POINTER -> OtherError CCI_E_POINTER + other -> HRESULTError other + + +-- | @COM@ failed to initialize. +data CoInitializeError + = CI_RPC_E_CHANGED_MODE + -- ^ A previous call to CoInitializeEx specified the concurrency model + -- for this thread as multithread apartment (MTA). + -- This could also indicate that a change from neutral-threaded + -- apartment to single-threaded apartment has occurred. + | CI_CO_E_NOTINITIALIZED + -- ^ You need to initialize the @COM@ library on a thread + -- before you call any of the library functions. + -- Otherwise, the @COM@ function will return 'CI_CO_E_NOTINITIALIZED'. + deriving (Show) + +toCoInitializeError :: HRESULTError -> Either (OrHRESULTError CoInitializeError) () +toCoInitializeError = Left . \case + HRESULTUnknown x + | x == -2147417850 -- 0x80010106 + -> OtherError CI_RPC_E_CHANGED_MODE + | x == -2147221008 -- 0x800401F0 + -> OtherError CI_CO_E_NOTINITIALIZED + other -> HRESULTError other + + +-- | @IPersistFile@ interface failed to save a file. +data SaveError + = SE_S_FALSE + -- ^ The object was not successfully saved. + deriving (Show) + +toSaveError :: HRESULTError -> Either (OrHRESULTError SaveError) () +toSaveError = \case + HRESULTUnknown x + | x == s_FALSE -> Left (OtherError SE_S_FALSE) + other -> Left (HRESULTError other) + + +-- | @IPersistFile@ interface failed to load a file. +data LoadError + = LE_E_OUTOFMEMORY + -- ^ The object could not be loaded due to a lack of memory. + | LE_E_FAIL + -- ^ The object could not be loaded for some reason + -- other than a lack of memory. + deriving (Show) + +toLoadError :: HRESULTError -> Either (OrHRESULTError LoadError) () +toLoadError = Left . \case + E_OUTOFMEMORY -> OtherError LE_E_OUTOFMEMORY + E_FAIL -> OtherError LE_E_FAIL + other -> HRESULTError other + + +data PathError + = Path_S_FALSE + -- ^ The operation is successful but no path is retrieved. + | PathTooLong + -- ^ Path length >= 260 characters. + deriving (Show) + +toPathError :: HRESULTError -> Either (OrHRESULTError PathError) () +toPathError = \case + HRESULTUnknown x + | x == s_FALSE -> Left (OtherError Path_S_FALSE) + other -> Left (HRESULTError other) + + +data ArgumentsError + = ArgumentsTooLong + -- ^ Arguments length >= 32768 characters. + deriving (Show) + + +data WorkingDirectoryError + = WorkingDirectoryTooLong + deriving (Show) + + +data DescriptionError + = DescriptionTooLong + deriving (Show) + + +data IconLocationError + = IconLocationTooLong + deriving (Show) + + +-- | Catch-all type for errors. +data ShortcutError + = InitializationError (OrHRESULTError CoInitializeError) + | CreateIShellLinkInterfaceError (OrHRESULTError CoCreateInstanceError) + | CreateIPersistFileInterfaceError (OrHRESULTError CoCreateInstanceError) + | LoadError (OrHRESULTError LoadError) + | SaveError (OrHRESULTError SaveError) + | InvalidPath (OrHRESULTError PathError) + | InvalidArguments (OrHRESULTError ArgumentsError) + | InvalidWorkingDirectory (OrHRESULTError WorkingDirectoryError) + | InvalidDescription (OrHRESULTError DescriptionError) + | InvalidIconLocation (OrHRESULTError IconLocationError) + | InvalidHotkey HRESULTError + | InvalidShowCmd HRESULTError + deriving (Show) diff --git a/src/System/Win32/Shortcut/Internal.hs b/src/System/Win32/Shortcut/Internal.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/Shortcut/Internal.hs @@ -0,0 +1,514 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +module System.Win32.Shortcut.Internal ( + module Foreign, + module Foreign.C, + module System.Win32, + ULONG, + OLECHAR, + LPCOLESTR, + LPOLESTR, + WINBOOL, + tRUE, + fALSE, + mAX_PATH, + GUID (..), + CLSID, + IID, + REFIID, + REFCLSID, + WIN32_FIND_DATAW (..), + SHITEMID (..), + ITEMIDLIST (..), + LPITEMIDLIST, + PIDLIST_ABSOLUTE, + LPCITEMIDLIST, + PCIDLIST_ABSOLUTE, + HWND__ (..), + HWND, + VtblPtrFun, + VtblMethod, + MethodCast, + IShellLinkWMethod, + IShellLinkW (..), + IShellLinkWVtbl (..), + IShellLinkWMethodCast, + dynIshQueryInterface, + dynIshAddRef, + dynIshRelease, + dynGetPath, + dynGetIDList, + dynSetIDList, + dynGetDescription, + dynSetDescription, + dynGetWorkingDirectory, + dynSetWorkingDirectory, + dynGetArguments, + dynSetArguments, + dynGetHotkey, + dynSetHotkey, + dynGetShowCmd, + dynSetShowCmd, + dynGetIconLocation, + dynSetIconLocation, + dynSetRelativePath, + dynResolve, + dynSetPath, + IUnknownMethod, + IUnknown (..), + IUnknownVtbl (..), + IUnknownMethodCast, + dynIuQueryInterface, + dynIuAddRef, + dynIuRelease, + LPUNKNOWN, + IPersistFileMethod, + IPersistFile (..), + IPersistFileVtbl (..), + IPersistFileMethodCast, + dynIpQueryInterface, + dynIpAddRef, + dynIpRelease, + dynGetClassID, + dynIsDirty, + dynLoad, + dynSave, + dynSaveCompleted, + dynGetCurFile, + cLSCTX_INPROC_HANDLER, + cLSCTX_INPROC_SERVER, + cLSCTX_LOCAL_SERVER, + cLSCTX_REMOTE_SERVER, + cLSCTX_ALL, + sW_SHOWNORMAL, + sW_SHOWMAXIMIZED, + sW_SHOWMINNOACTIVE, + s_OK, + s_FALSE, + e_ABORT, + e_ACCESSDENIED, + e_FAIL, + e_HANDLE, + e_INVALIDARG, + e_NOINTERFACE, + e_NOTIMPL, + e_OUTOFMEMORY, + e_POINTER, + e_UNEXPECTED, + SLGP_FLAGS, + sLGP_SHORTPATH, + sLGP_UNCPRIORITY, + sLGP_RAWPATH, + sLGP_RELATIVEPRIORITY, + sTGM_READ, + COINITBASE, + cOINITBASE_MULTITHREADED, + COINIT, + cOINIT_APARTMENTTHREADED, + cOINIT_MULTITHREADED, + cOINIT_DISABLE_OLE1DDE, + cOINIT_SPEED_OVER_MEMORY, + c_CoInitializeEx, + c_CoUninitialize, + c_CoCreateInstance, + c_CLSID_ShellLink, + c_IID_IShellLinkW, + c_IID_IPersistFile +) +where + +import Foreign ( + Storable(..), + Ptr, + FunPtr, + nullPtr, + castPtr, + with, + (.|.)) +import Foreign.C ( + CInt (..), + CWchar, + withCWString) +import System.Win32 ( + UCHAR, + USHORT, + BYTE, + WORD, + DWORD, + LPVOID, + LPCWSTR, + LPWSTR, + FILETIME, + HRESULT) +import TH.Derive ( + Deriving, + derive) + +#include "windows_cconv.h" + +type ULONG = DWORD + +type OLECHAR = CWchar + +type LPCOLESTR = Ptr OLECHAR + +type LPOLESTR = Ptr OLECHAR + +type WINBOOL = CInt + +tRUE, fALSE :: WINBOOL +tRUE = 1 +fALSE = 0 + +mAX_PATH :: CInt +mAX_PATH = 260 + +data GUID = GUID { + data1 :: !ULONG, + data2 :: !USHORT, + data3 :: !USHORT, + data4 :: !(Ptr UCHAR) -- uchar[8] +} deriving (Show) + +$($(derive [d| instance Deriving (Storable GUID) |])) + +type CLSID = GUID + +type IID = GUID + +type REFIID = Ptr IID + +type REFCLSID = Ptr IID + + +data WIN32_FIND_DATAW = WIN32_FIND_DATAW { + dwFileAttributes :: !DWORD, + ftCreationTime :: !FILETIME, + ftLastAccessTime :: !FILETIME, + ftLastWriteTime :: !FILETIME, + nFileSizeHigh :: !DWORD, + nFileSizeLow :: !DWORD, + dwReserved0 :: !DWORD, + dwReserved1 :: !DWORD, + cFileName :: !(Ptr CWchar), -- char[max_path] + cAlternateFileName :: !(Ptr CWchar) -- char[14] +} deriving (Show) + +$($(derive [d| instance Deriving (Storable WIN32_FIND_DATAW) |])) + + +data SHITEMID = SHITEMID { + cb :: !USHORT, + abID :: !(Ptr BYTE) -- BYTE[1] +} deriving (Show) + +$($(derive [d| instance Deriving (Storable SHITEMID) |])) + + +newtype ITEMIDLIST = ITEMIDLIST { + mkid :: SHITEMID +} deriving (Show) + +$($(derive [d| instance Deriving (Storable ITEMIDLIST) |])) + +type LPITEMIDLIST = Ptr ITEMIDLIST + +type PIDLIST_ABSOLUTE = LPITEMIDLIST + +type LPCITEMIDLIST = Ptr ITEMIDLIST + +type PCIDLIST_ABSOLUTE = LPCITEMIDLIST + + +newtype HWND__ = HWND__ { + unused :: CInt +} deriving (Show) + +$($(derive [d| instance Deriving (Storable HWND__) |])) + +type HWND = Ptr HWND__ + + +type VtblPtrFun struct fun = Ptr struct -> fun + +type VtblMethod struct fun = FunPtr (VtblPtrFun struct fun) + +type MethodCast struct fun = VtblMethod struct fun -> VtblPtrFun struct fun + + +type IShellLinkWMethod fun = VtblMethod IShellLinkW fun + +newtype IShellLinkW = IShellLinkW { + ishlpVtbl :: Ptr IShellLinkWVtbl +} deriving (Show) + +data IShellLinkWVtbl = IShellLinkWVtbl { + ishQueryInterface :: !(IShellLinkWMethod (REFIID -> Ptr (Ptr ()) -> IO HRESULT)), + ishAddRef :: !(IShellLinkWMethod (IO ULONG)), + ishRelease :: !(IShellLinkWMethod (IO ULONG)), + getPath :: !(IShellLinkWMethod (LPWSTR -> CInt -> Ptr WIN32_FIND_DATAW -> DWORD -> IO HRESULT)), + getIDList :: !(IShellLinkWMethod (Ptr PIDLIST_ABSOLUTE -> IO HRESULT)), + setIDList :: !(IShellLinkWMethod (PCIDLIST_ABSOLUTE -> IO HRESULT)), + getDescription :: !(IShellLinkWMethod (LPWSTR -> CInt -> IO HRESULT)), + setDescription :: !(IShellLinkWMethod (LPCWSTR -> IO HRESULT)), + getWorkingDirectory :: !(IShellLinkWMethod (LPWSTR -> CInt -> IO HRESULT)), + setWorkingDirectory :: !(IShellLinkWMethod (LPCWSTR -> IO HRESULT)), + getArguments :: !(IShellLinkWMethod (LPWSTR -> CInt -> IO HRESULT)), + setArguments :: !(IShellLinkWMethod (LPCWSTR -> IO HRESULT)), + getHotkey :: !(IShellLinkWMethod (Ptr WORD -> IO HRESULT)), + setHotkey :: !(IShellLinkWMethod (WORD -> IO HRESULT)), + getShowCmd :: !(IShellLinkWMethod (Ptr CInt -> IO HRESULT)), + setShowCmd :: !(IShellLinkWMethod (CInt -> IO HRESULT)), + getIconLocation :: !(IShellLinkWMethod (LPWSTR -> CInt -> Ptr CInt -> IO HRESULT)), + setIconLocation :: !(IShellLinkWMethod (LPCWSTR -> CInt -> IO HRESULT)), + setRelativePath :: !(IShellLinkWMethod (LPCWSTR -> DWORD -> IO HRESULT)), + resolve :: !(IShellLinkWMethod (HWND -> DWORD -> IO HRESULT)), + setPath :: !(IShellLinkWMethod (LPCWSTR -> IO HRESULT)) +} deriving (Show) + +$($(derive [d| instance Deriving (Storable IShellLinkW) |])) +$($(derive [d| instance Deriving (Storable IShellLinkWVtbl) |])) + +type IShellLinkWMethodCast fun = MethodCast IShellLinkW fun + +foreign import WINDOWS_CCONV "dynamic" + dynIshQueryInterface :: IShellLinkWMethodCast (REFIID -> Ptr (Ptr ()) -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynIshAddRef :: IShellLinkWMethodCast (IO ULONG) + +foreign import WINDOWS_CCONV "dynamic" + dynIshRelease :: IShellLinkWMethodCast (IO ULONG) + +foreign import WINDOWS_CCONV "dynamic" + dynGetPath :: IShellLinkWMethodCast (LPWSTR -> CInt -> Ptr WIN32_FIND_DATAW -> DWORD -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynGetIDList :: IShellLinkWMethodCast (Ptr PIDLIST_ABSOLUTE -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynSetIDList :: IShellLinkWMethodCast (PCIDLIST_ABSOLUTE -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynGetDescription :: IShellLinkWMethodCast (LPWSTR -> CInt -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynSetDescription :: IShellLinkWMethodCast (LPCWSTR -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynGetWorkingDirectory :: IShellLinkWMethodCast (LPWSTR -> CInt -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynSetWorkingDirectory :: IShellLinkWMethodCast (LPCWSTR -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynGetArguments :: IShellLinkWMethodCast (LPWSTR -> CInt -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynSetArguments :: IShellLinkWMethodCast (LPCWSTR -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynGetHotkey :: IShellLinkWMethodCast (Ptr WORD -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynSetHotkey :: IShellLinkWMethodCast (WORD -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynGetShowCmd :: IShellLinkWMethodCast (Ptr CInt -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynSetShowCmd :: IShellLinkWMethodCast (CInt -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynGetIconLocation :: IShellLinkWMethodCast (LPWSTR -> CInt -> Ptr CInt -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynSetIconLocation :: IShellLinkWMethodCast (LPCWSTR -> CInt -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynSetRelativePath :: IShellLinkWMethodCast (LPCWSTR -> DWORD -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynResolve :: IShellLinkWMethodCast (HWND -> DWORD -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynSetPath :: IShellLinkWMethodCast (LPCWSTR -> IO HRESULT) + + +type IUnknownMethod fun = VtblMethod IUnknown fun + +newtype IUnknown = IUnknown { + iunklpVtbl :: Ptr IUnknownVtbl +} deriving (Show) + +data IUnknownVtbl = IUnknownVtbl { + iuQueryInterface :: !(IUnknownMethod (REFIID -> Ptr (Ptr ()) -> IO HRESULT)), + iuAddRef :: !(IUnknownMethod (IO ULONG)), + iuRelease :: !(IUnknownMethod (IO ULONG)) +} deriving (Show) + +$($(derive [d| instance Deriving (Storable IUnknown) |])) +$($(derive [d| instance Deriving (Storable IUnknownVtbl) |])) + +type IUnknownMethodCast fun = MethodCast IUnknown fun + +foreign import WINDOWS_CCONV "dynamic" + dynIuQueryInterface :: IUnknownMethodCast (REFIID -> Ptr (Ptr ()) -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynIuAddRef :: IUnknownMethodCast (IO ULONG) + +foreign import WINDOWS_CCONV "dynamic" + dynIuRelease :: IUnknownMethodCast (IO ULONG) + +type LPUNKNOWN = Ptr IUnknown + + +type IPersistFileMethod fun = VtblMethod IPersistFile fun + +newtype IPersistFile = IPersistFile { + iplpVtbl :: Ptr IPersistFileVtbl +} deriving (Show) + +data IPersistFileVtbl = IPersistFileVtbl { + ipQueryInterface :: !(IPersistFileMethod (REFIID -> Ptr (Ptr ()) -> IO HRESULT)), + ipAddRef :: !(IPersistFileMethod (IO ULONG)), + ipRelease :: !(IPersistFileMethod (IO ULONG)), + getClassID :: !(IPersistFileMethod (Ptr CLSID -> IO HRESULT)), + isDirty :: !(IPersistFileMethod (IO HRESULT)), + load :: !(IPersistFileMethod (LPCOLESTR -> DWORD -> IO HRESULT)), + save :: !(IPersistFileMethod (LPCOLESTR -> WINBOOL -> IO HRESULT)), + saveCompleted :: !(IPersistFileMethod (LPCOLESTR -> IO HRESULT)), + getCurFile :: !(IPersistFileMethod (Ptr LPOLESTR -> IO HRESULT)) +} deriving (Show) + +$($(derive [d| instance Deriving (Storable IPersistFile) |])) +$($(derive [d| instance Deriving (Storable IPersistFileVtbl) |])) + +type IPersistFileMethodCast fun = MethodCast IPersistFile fun + +foreign import WINDOWS_CCONV "dynamic" + dynIpQueryInterface :: IPersistFileMethodCast (REFIID -> Ptr (Ptr ()) -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynIpAddRef :: IPersistFileMethodCast (IO ULONG) + +foreign import WINDOWS_CCONV "dynamic" + dynIpRelease :: IPersistFileMethodCast (IO ULONG) + +foreign import WINDOWS_CCONV "dynamic" + dynGetClassID :: IPersistFileMethodCast (Ptr CLSID -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynIsDirty :: IPersistFileMethodCast (IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynLoad :: IPersistFileMethodCast (LPCOLESTR -> DWORD -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynSave :: IPersistFileMethodCast (LPCOLESTR -> WINBOOL -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynSaveCompleted :: IPersistFileMethodCast (LPCOLESTR -> IO HRESULT) + +foreign import WINDOWS_CCONV "dynamic" + dynGetCurFile :: IPersistFileMethodCast (Ptr LPOLESTR -> IO HRESULT) + + +cLSCTX_INPROC_SERVER, cLSCTX_INPROC_HANDLER :: DWORD +cLSCTX_LOCAL_SERVER, cLSCTX_REMOTE_SERVER, cLSCTX_ALL :: DWORD +cLSCTX_INPROC_SERVER = 0x1 +cLSCTX_INPROC_HANDLER = 0x2 +cLSCTX_LOCAL_SERVER = 0x4 +cLSCTX_REMOTE_SERVER = 0x10 +cLSCTX_ALL = cLSCTX_INPROC_SERVER + .|. cLSCTX_INPROC_HANDLER + .|. cLSCTX_LOCAL_SERVER + .|. cLSCTX_REMOTE_SERVER + + +sW_SHOWNORMAL :: CInt +sW_SHOWNORMAL = 1 + +sW_SHOWMAXIMIZED :: CInt +sW_SHOWMAXIMIZED = 3 + +sW_SHOWMINNOACTIVE :: CInt +sW_SHOWMINNOACTIVE = 7 + + +s_OK, s_FALSE, e_ABORT, e_ACCESSDENIED, e_FAIL, e_HANDLE, e_INVALIDARG :: HRESULT +e_NOINTERFACE, e_NOTIMPL, e_OUTOFMEMORY, e_POINTER, e_UNEXPECTED :: HRESULT +s_OK = 0 -- 0x00000000 - negative hex literals +s_FALSE = 1 -- 0x00000001 trigger a warning +e_ABORT = -2147467260 -- 0x80004004 +e_ACCESSDENIED = -2147024891 -- 0x80070005 +e_FAIL = -2147467259 -- 0x80004005 +e_HANDLE = -2147024890 -- 0x80070006 +e_INVALIDARG = -2147024809 -- 0x80070057 +e_NOINTERFACE = -2147467262 -- 0x80004002 +e_NOTIMPL = -2147467263 -- 0x80004001 +e_OUTOFMEMORY = -2147024882 -- 0x8007000E +e_POINTER = -2147467261 -- 0x80004003 +e_UNEXPECTED = -2147418113 -- 0x8000FFFF + + +type SLGP_FLAGS = DWORD + +sLGP_SHORTPATH :: SLGP_FLAGS +sLGP_SHORTPATH = 0x1 + +sLGP_UNCPRIORITY :: SLGP_FLAGS +sLGP_UNCPRIORITY = 0x2 + +sLGP_RAWPATH :: SLGP_FLAGS +sLGP_RAWPATH = 0x4 + +sLGP_RELATIVEPRIORITY :: SLGP_FLAGS +sLGP_RELATIVEPRIORITY = 0x8 + + +sTGM_READ :: DWORD +sTGM_READ = 0x00000000 + + +type COINITBASE = DWORD + +cOINITBASE_MULTITHREADED :: COINITBASE +cOINITBASE_MULTITHREADED = 0x0 + +type COINIT = DWORD + +cOINIT_APARTMENTTHREADED :: COINIT +cOINIT_APARTMENTTHREADED = 0x2 + +cOINIT_MULTITHREADED :: COINIT +cOINIT_MULTITHREADED = cOINITBASE_MULTITHREADED + +cOINIT_DISABLE_OLE1DDE :: COINIT +cOINIT_DISABLE_OLE1DDE = 0x4 + +cOINIT_SPEED_OVER_MEMORY :: COINIT +cOINIT_SPEED_OVER_MEMORY = 0x8 + + +foreign import WINDOWS_CCONV "objbase.h CoInitializeEx" + c_CoInitializeEx :: LPVOID -> DWORD -> IO HRESULT + +foreign import WINDOWS_CCONV "objbase.h CoUninitialize" + c_CoUninitialize :: IO () + + +foreign import WINDOWS_CCONV "combaseapi.h CoCreateInstance" + c_CoCreateInstance :: REFCLSID -> LPUNKNOWN -> DWORD -> REFIID -> Ptr LPVOID -> IO HRESULT + + +foreign import WINDOWS_CCONV "shobjidl.h &CLSID_ShellLink" + c_CLSID_ShellLink :: Ptr GUID + +foreign import WINDOWS_CCONV "shobjidl.h &IID_IShellLinkW" + c_IID_IShellLinkW :: Ptr GUID + +foreign import WINDOWS_CCONV "shobjidl.h &IID_IPersistFile" + c_IID_IPersistFile :: Ptr GUID