----------------------------------------------------------------------------- -- | -- Module : System.Win32.SimpleMAPI -- Copyright : (c) Esa Ilari Vuokko, 2006 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Esa Ilari Vuokko -- Stability : provisional -- Portability : portable -- -- FFI-bindings to interact with SimpleMAPI -- ----------------------------------------------------------------------------- module System.Win32.SimpleMAPI where import Control.Exception ( bracket, handle, finally, onException , IOException ) import Control.Monad ( liftM5 ) import Foreign ( FunPtr, newForeignPtr, pokeByteOff, maybeWith , Ptr, castPtr, castPtrToFunPtr, nullPtr , touchForeignPtr, alloca, peek, allocaBytes , minusPtr, plusPtr, copyBytes, ForeignPtr ) import Foreign.C ( withCString, withCStringLen ) import Graphics.Win32.GDI.Types ( HWND) import System.Win32.DLL ( loadLibrary, c_GetProcAddress, freeLibrary , c_FreeLibraryFinaliser ) import System.Win32.Types ( DWORD, LPSTR, HMODULE, failIfNull ) #include "windows.h" #include "mapi.h" type ULONG = DWORD type LHANDLE = ULONG newtype MapiRecipDesc = MapiRecipDesc () type MapiFlag = ULONG #{enum MapiFlag, , mAPI_LOGON_UI = MAPI_LOGON_UI , mAPI_NEW_SESSION = MAPI_NEW_SESSION , mAPI_FORCE_DOWNLOAD = MAPI_FORCE_DOWNLOAD , mAPI_LOGOFF_SHARED = MAPI_LOGOFF_SHARED , mAPI_LOGOFF_UI = MAPI_LOGOFF_UI , mAPI_DIALOG = MAPI_DIALOG , mAPI_UNREAD_ONLY = MAPI_UNREAD_ONLY , mAPI_LONG_MSGID = MAPI_LONG_MSGID , mAPI_GUARANTEE_FIFO = MAPI_GUARANTEE_FIFO , mAPI_ENVELOPE_ONLY = MAPI_ENVELOPE_ONLY , mAPI_PEEK = MAPI_PEEK , mAPI_BODY_AS_FILE = MAPI_BODY_AS_FILE , mAPI_SUPPRESS_ATTACH = MAPI_SUPPRESS_ATTACH , mAPI_AB_NOMODIFY = MAPI_AB_NOMODIFY , mAPI_OLE = MAPI_OLE , mAPI_OLE_STATIC = MAPI_OLE_STATIC , mAPI_UNREAD = MAPI_UNREAD , mAPI_RECEIPT_REQUESTED = MAPI_RECEIPT_REQUESTED , mAPI_SENT = MAPI_SENT } mapiErrors :: [(ULONG,String)] mapiErrors = [ ((#const SUCCESS_SUCCESS) , "Success") , ((#const MAPI_E_FAILURE) , "Generic error or multiple errors") , ((#const MAPI_E_USER_ABORT) , "User aborted") , ((#const MAPI_E_LOGIN_FAILURE) , "Logoff failed") , ((#const MAPI_E_LOGON_FAILURE) , "Logon failed") , ((#const MAPI_E_DISK_FULL) , "Disk full") , ((#const MAPI_E_INSUFFICIENT_MEMORY) , "Not enough memory") , ((#const MAPI_E_ACCESS_DENIED) , "Access denied") , ((#const MAPI_E_BLK_TOO_SMALL) , "BLK_TOO_SMALL") , ((#const MAPI_E_TOO_MANY_SESSIONS), "Too many open sessions") , ((#const MAPI_E_TOO_MANY_FILES) , "Too many open files") , ((#const MAPI_E_TOO_MANY_RECIPIENTS) , "Too many recipients") , ((#const MAPI_E_ATTACHMENT_NOT_FOUND) , "Attachemnt not found") , ((#const MAPI_E_ATTACHMENT_OPEN_FAILURE) , "Couldn't open attachment") , ((#const MAPI_E_ATTACHMENT_WRITE_FAILURE) , "Couldn't write attachment") , ((#const MAPI_E_UNKNOWN_RECIPIENT) , "Unknown recipient") , ((#const MAPI_E_BAD_RECIPTYPE) , "Bad recipient type") , ((#const MAPI_E_NO_MESSAGES) , "No messages") , ((#const MAPI_E_INVALID_MESSAGE) , "Invalid message") , ((#const MAPI_E_TEXT_TOO_LARGE) , "Text too large") , ((#const MAPI_E_INVALID_SESSION) , "Invalid session") , ((#const MAPI_E_TYPE_NOT_SUPPORTED) , "Type not supported") , ((#const MAPI_E_AMBIGUOUS_RECIPIENT) , "Ambigious recipient") , ((#const MAPI_E_AMBIGUOUS_RECIP) , "Ambigious recipient") , ((#const MAPI_E_MESSAGE_IN_USE) , "Message in use") , ((#const MAPI_E_NETWORK_FAILURE) , "Network failure") , ((#const MAPI_E_INVALID_EDITFIELDS) , "Invalid editfields") , ((#const MAPI_E_INVALID_RECIPS) , "Invalid recipient(s)") , ((#const MAPI_E_NOT_SUPPORTED) , "Not supported") ] mapiErrorString :: ULONG -> String mapiErrorString c = case lookup c mapiErrors of Nothing -> "Unkown error (" ++ show c ++ ")" Just x -> x mapiFail :: String -> IO ULONG -> IO ULONG mapiFail name act = act >>= \err -> if err==(#const SUCCESS_SUCCESS) then return err else fail $ name ++ ": " ++ mapiErrorString err mapiFail_ :: String -> IO ULONG -> IO () mapiFail_ n a = mapiFail n a >> return () type MapiLogonType = ULONG -> LPSTR -> LPSTR -> MapiFlag -> ULONG -> Ptr LHANDLE -> IO ULONG foreign import stdcall "dynamic" mkMapiLogon :: FunPtr MapiLogonType -> MapiLogonType type MapiLogoffType = LHANDLE -> ULONG -> MapiFlag -> ULONG -> IO ULONG foreign import stdcall "dynamic" mkMapiLogoff :: FunPtr MapiLogoffType -> MapiLogoffType type MapiResolveNameType = LHANDLE -> ULONG -> LPSTR -> MapiFlag -> ULONG -> Ptr (Ptr MapiRecipDesc) -> IO ULONG foreign import stdcall "dynamic" mkMapiResolveName :: FunPtr MapiResolveNameType -> MapiResolveNameType type MapiFreeBufferType = Ptr () -> IO ULONG foreign import stdcall "dynamic" mkMapiFreeBuffer :: FunPtr MapiFreeBufferType -> MapiFreeBufferType type MapiSendMailType = LHANDLE -> ULONG -> Ptr Message -> MapiFlag -> ULONG -> IO ULONG foreign import stdcall "dynamic" mkMapiSendMail :: FunPtr MapiSendMailType -> MapiSendMailType data MapiFuncs = MapiFuncs { mapifLogon :: MapiLogonType , mapifLogoff :: MapiLogoffType , mapifResolveName :: MapiResolveNameType , mapifFreeBuffer :: MapiFreeBufferType , mapifSendMail :: MapiSendMailType } type MapiLoaded = (MapiFuncs, ForeignPtr ()) -- | loadMapiFuncs :: String -> HMODULE -> IO MapiFuncs loadMapiFuncs dllname dll = liftM5 MapiFuncs (loadProc "MAPILogon" dll mkMapiLogon) (loadProc "MAPILogoff" dll mkMapiLogoff) (loadProc "MAPIResolveName" dll mkMapiResolveName) (loadProc "MAPIFreeBuffer" dll mkMapiFreeBuffer) (loadProc "MAPISendMail" dll mkMapiSendMail) where loadProc name dll conv = withCString name $ \name' -> do proc <- failIfNull ("loadMapiDll: " ++ dllname ++ ": " ++ name) $ c_GetProcAddress dll name' return $ conv $ castPtrToFunPtr proc -- | loadMapiDll :: String -> IO (MapiFuncs, HMODULE) loadMapiDll dllname = do dll <- loadLibrary dllname do funcs <- loadMapiFuncs dllname dll return (funcs, dll) `onException` freeLibrary dll -- | withMapiFuncs :: [String] -> (MapiFuncs -> IO a) -> IO a withMapiFuncs dlls act = bracket load free (act . fst) where loadOne l = case l of [] -> fail $ "withMapiFuncs: Failed to load DLLs: " ++ show dlls x:y -> handleIOException (const $ loadOne y) (loadMapiDll x) load = loadOne dlls free = freeLibrary . snd -- | loadMapi :: [String] -> IO MapiLoaded loadMapi dlls = do (f,m) <- loadOne dlls m' <- newForeignPtr c_FreeLibraryFinaliser m return (f,m') where loadOne l = case l of [] -> fail $ "loadMapi: Failed to load any of DLLs: " ++ show dlls x:y -> handleIOException (const $ loadOne y) (loadMapiDll x) -- | withMapiLoaded :: MapiLoaded -> (MapiFuncs -> IO a) -> IO a withMapiLoaded (f,m) act = finally (act f) (touchForeignPtr m) maybeHWND :: Maybe HWND -> ULONG maybeHWND = maybe 0 (fromIntegral . flip minusPtr nullPtr) -- | Create Simple MAPI-session by logon mapiLogon :: MapiFuncs -- ^ Functions loaded from MAPI DLL -> Maybe HWND -- ^ Parent window, used for modal logon dialog -> Maybe String -- ^ Session -> Maybe String -- ^ Password -> MapiFlag -- ^ None, one or many flags: FORCE_DOWNLOAD, NEW_SESSION, LOGON_UI, PASSWORD_UI -> IO LHANDLE mapiLogon f hwnd ses pw flags = maybeWith withCString ses $ \ses -> maybeWith withCString pw $ \pw -> alloca $ \out -> do mapiFail_ "MAPILogon: " $ mapifLogon f (maybeHWND hwnd) ses pw flags 0 out peek out -- | End Simple MAPI-session mapiLogoff :: MapiFuncs -> LHANDLE -> Maybe HWND -> IO () mapiLogoff f ses hwnd = mapiFail_ "MAPILogoff" $ mapifLogoff f ses (maybeHWND hwnd) 0 0 data RecipientClass = RcOriginal | RcTo | RcCc | RcBcc deriving (Show, Eq, Ord, Enum) rcToULONG :: RecipientClass -> ULONG rcToULONG = fromIntegral . fromEnum uLONGToRc :: ULONG -> RecipientClass uLONGToRc = toEnum . fromIntegral data Recipient = RecipResolve (Maybe HWND) MapiFlag String (Maybe Recipient) | Recip String String deriving (Show) type Recipients = [(RecipientClass, Recipient)] simpleRecip :: String -> Recipient simpleRecip s = RecipResolve Nothing 0 s $ Just $ Recip s s withRecipient :: MapiFuncs -> LHANDLE -> RecipientClass -> Recipient -> (Ptr MapiRecipDesc -> IO a) -> IO a withRecipient f ses rcls rec act = resolve "" rec where a buf = do (#poke MapiRecipDesc, ulRecipClass) buf (rcToULONG rcls) act buf resolve err rc = case rc of Recip name addr -> withCString name $ \name -> withCString addr $ \addr -> allocaBytes (#size MapiRecipDesc) $ \buf -> do (#poke MapiRecipDesc, ulReserved) buf (0::ULONG) (#poke MapiRecipDesc, lpszName) buf name (#poke MapiRecipDesc, lpszAddress) buf addr (#poke MapiRecipDesc, ulEIDSize) buf (0::ULONG) (#poke MapiRecipDesc, lpEntryID) buf nullPtr a buf RecipResolve hwnd flag name fallback -> do res <- alloca $ \res -> withCString name $ \name' -> do errn <- mapifResolveName f ses (maybeHWND hwnd) name' flag 0 res if errn==(#const SUCCESS_SUCCESS) then do buf <- peek res v <- a buf _ <- mapifFreeBuffer f $ castPtr buf return $ Right v else return $ Left $ err ++ ", " ++ name ++ ":" ++ mapiErrorString errn case res of Left e -> case fallback of Nothing -> fail $ "Failed to resolve any of the recipients: " ++ e Just x -> resolve e x Right x -> return x withRecipients :: MapiFuncs -> LHANDLE -> Recipients -> (Int -> Ptr MapiRecipDesc -> IO a) -> IO a withRecipients f ses rec act = w [] rec where w res [] = allocaBytes (length res*rs) $ \buf -> do mapM_ (write buf) $ zip [0..] $ reverse res act (length res) buf w res ((c,r):y) = withRecipient f ses c r $ \x -> w (x:res) y rs = (#size MapiRecipDesc) write buf (off,src) = do let buf' = plusPtr buf (off*rs) copyBytes buf' src rs data FileTag = FileTag { ftTag :: Maybe String -- ^ mime , ftEncoding :: Maybe String } deriving (Show) defFileTag :: FileTag defFileTag = FileTag Nothing Nothing withFileTag :: FileTag -> (Ptr FileTag -> IO a) -> IO a withFileTag ft act = allocaBytes (#size MapiFileTagExt) $ \buf -> w (ftTag ft) $ \(tbuf,tsiz) -> w (ftEncoding ft) $ \(ebuf,esiz) -> do (#poke MapiFileTagExt, ulReserved) buf (0::ULONG) (#poke MapiFileTagExt, cbTag) buf tsiz (#poke MapiFileTagExt, lpTag) buf tbuf (#poke MapiFileTagExt, cbEncoding) buf esiz (#poke MapiFileTagExt, lpEncoding) buf ebuf act buf where w v a = case v of Nothing -> a (nullPtr, 0) Just x -> withCStringLen x a data Attachment = Attachment { attFlag :: MapiFlag , attPosition :: Maybe ULONG , attPath :: String , attName :: Maybe String , attTag :: Maybe FileTag } deriving (Show) defAttachment :: Attachment defAttachment = Attachment 0 Nothing "" Nothing Nothing type Attachments = [Attachment] withAttachments :: Attachments -> (Int -> Ptr Attachment -> IO a) -> IO a withAttachments att act = allocaBytes (len*as) $ \buf -> write (act len buf) buf att where as = (#size MapiFileDesc) len = length att write act _ [] = act write act buf (att:y) = withCString (attPath att) $ \path -> maybeWith withFileTag (attTag att) $ \tag -> withCString (maybe (attPath att) id (attName att)) $ \name -> do (#poke MapiFileDesc, ulReserved) buf (0::ULONG) (#poke MapiFileDesc, flFlags) buf (attFlag att) (#poke MapiFileDesc, nPosition) buf (maybe 0xffffffff id $ attPosition att) (#poke MapiFileDesc, lpszPathName) buf path (#poke MapiFileDesc, lpszFileName) buf name (#poke MapiFileDesc, lpFileType) buf tag write act (plusPtr buf as) y data Message = Message { msgSubject :: String , msgBody :: String , msgType :: Maybe String , msgDate :: Maybe String , msgConversationId :: Maybe String , msgFlags :: MapiFlag , msgFrom :: Maybe Recipient , msgRecips :: Recipients , msgAttachments :: Attachments } deriving (Show) defMessage :: Message defMessage = Message "" "" Nothing Nothing Nothing 0 Nothing [] [] withMessage :: MapiFuncs -> LHANDLE -> Message -> (Ptr Message -> IO a) -> IO a withMessage f ses m act = withCString (msgSubject m) $ \subject -> withCString (msgBody m) $ \body -> maybeWith withCString (msgType m) $ \message_type -> maybeWith withCString (msgDate m) $ \date -> maybeWith withCString (msgConversationId m) $ \conv_id -> withRecipients f ses (msgRecips m) $ \rlen rbuf -> withAttachments (msgAttachments m) $ \alen abuf -> maybeWith (withRecipient f ses RcOriginal) (msgFrom m) $ \from -> allocaBytes (#size MapiMessage) $ \buf -> do (#poke MapiMessage, ulReserved) buf (0::ULONG) (#poke MapiMessage, lpszSubject) buf subject (#poke MapiMessage, lpszNoteText) buf body (#poke MapiMessage, lpszMessageType) buf message_type (#poke MapiMessage, lpszDateReceived) buf date (#poke MapiMessage, lpszConversationID) buf conv_id (#poke MapiMessage, flFlags) buf (msgFlags m) (#poke MapiMessage, lpOriginator) buf from (#poke MapiMessage, nRecipCount) buf (fromIntegral rlen :: ULONG) (#poke MapiMessage, lpRecips) buf rbuf (#poke MapiMessage, nFileCount) buf alen (#poke MapiMessage, lpFiles) buf abuf act buf mapiSendMail :: MapiFuncs -> LHANDLE -> Maybe HWND -> Message -> MapiFlag -> IO () mapiSendMail f ses hwnd msg flag = withMessage f ses msg $ \msg -> mapiFail_ "MAPISendMail" $ mapifSendMail f ses (maybeHWND hwnd) msg flag 0 handleIOException :: (IOException -> IO a) -> IO a -> IO a handleIOException = handle