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 ( withCAString, withCAStringLen )
import Graphics.Win32.GDI.Types ( HWND)
import System.Win32.DLL ( loadLibrary, c_GetProcAddress, freeLibrary
, c_FreeLibraryFinaliser )
import System.Win32.Types ( DWORD, LPSTR, HMODULE, failIfNull )
type ULONG = DWORD
type LHANDLE = ULONG
newtype MapiRecipDesc = MapiRecipDesc ()
type MapiFlag = ULONG
mAPI_LOGON_UI :: MapiFlag
mAPI_LOGON_UI = 1
mAPI_NEW_SESSION :: MapiFlag
mAPI_NEW_SESSION = 2
mAPI_FORCE_DOWNLOAD :: MapiFlag
mAPI_FORCE_DOWNLOAD = 4096
mAPI_LOGOFF_SHARED :: MapiFlag
mAPI_LOGOFF_SHARED = 1
mAPI_LOGOFF_UI :: MapiFlag
mAPI_LOGOFF_UI = 2
mAPI_DIALOG :: MapiFlag
mAPI_DIALOG = 8
mAPI_UNREAD_ONLY :: MapiFlag
mAPI_UNREAD_ONLY = 32
mAPI_LONG_MSGID :: MapiFlag
mAPI_LONG_MSGID = 16384
mAPI_GUARANTEE_FIFO :: MapiFlag
mAPI_GUARANTEE_FIFO = 256
mAPI_ENVELOPE_ONLY :: MapiFlag
mAPI_ENVELOPE_ONLY = 64
mAPI_PEEK :: MapiFlag
mAPI_PEEK = 128
mAPI_BODY_AS_FILE :: MapiFlag
mAPI_BODY_AS_FILE = 512
mAPI_SUPPRESS_ATTACH :: MapiFlag
mAPI_SUPPRESS_ATTACH = 2048
mAPI_AB_NOMODIFY :: MapiFlag
mAPI_AB_NOMODIFY = 1024
mAPI_OLE :: MapiFlag
mAPI_OLE = 1
mAPI_OLE_STATIC :: MapiFlag
mAPI_OLE_STATIC = 2
mAPI_UNREAD :: MapiFlag
mAPI_UNREAD = 1
mAPI_RECEIPT_REQUESTED :: MapiFlag
mAPI_RECEIPT_REQUESTED = 2
mAPI_SENT :: MapiFlag
mAPI_SENT = 4
mapiErrors :: [(ULONG,String)]
mapiErrors =
[ ((0) , "Success")
, ((2) , "Generic error or multiple errors")
, ((1) , "User aborted")
, ((3) , "Logoff failed")
, ((3) , "Logon failed")
, ((4) , "Disk full")
, ((5) , "Not enough memory")
, ((6) , "Access denied")
, ((6) , "BLK_TOO_SMALL")
, ((8), "Too many open sessions")
, ((9) , "Too many open files")
, ((10) , "Too many recipients")
, ((11) , "Attachemnt not found")
, ((12) , "Couldn't open attachment")
, ((13) , "Couldn't write attachment")
, ((14) , "Unknown recipient")
, ((15) , "Bad recipient type")
, ((16) , "No messages")
, ((17) , "Invalid message")
, ((18) , "Text too large")
, ((19) , "Invalid session")
, ((20) , "Type not supported")
, ((21) , "Ambigious recipient")
, ((21) , "Ambigious recipient")
, ((22) , "Message in use")
, ((23) , "Network failure")
, ((24) , "Invalid editfields")
, ((25) , "Invalid recipient(s)")
, ((26) , "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==(0)
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 :: String -> HMODULE -> (FunPtr a -> a) -> IO a
loadProc name dll conv = withCAString 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)
mapiLogon
:: MapiFuncs
-> Maybe HWND
-> Maybe String
-> Maybe String
-> MapiFlag
-> IO LHANDLE
mapiLogon f hwnd ses pw flags =
maybeWith withCAString ses $ \ses ->
maybeWith withCAString pw $ \pw ->
alloca $ \out -> do
mapiFail_ "MAPILogon: " $ mapifLogon
f (maybeHWND hwnd)
ses pw flags 0 out
peek out
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
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) buf (rcToULONG rcls)
act buf
resolve err rc = case rc of
Recip name addr ->
withCAString name $ \name ->
withCAString addr $ \addr ->
allocaBytes ((24)) $ \buf -> do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) buf (0::ULONG)
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) buf name
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) buf addr
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) buf (0::ULONG)
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) buf nullPtr
a buf
RecipResolve hwnd flag name fallback -> do
res <- alloca $ \res ->
withCAString name $ \name' -> do
errn <- mapifResolveName
f ses (maybeHWND hwnd) name' flag 0 res
if errn==(0)
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 = ((24))
write buf (off,src) = do
let buf' = plusPtr buf (off*rs)
copyBytes buf' src rs
data FileTag = FileTag
{ ftTag :: Maybe String
, ftEncoding :: Maybe String
} deriving (Show)
defFileTag :: FileTag
defFileTag = FileTag Nothing Nothing
withFileTag :: FileTag -> (Ptr FileTag -> IO a) -> IO a
withFileTag ft act =
allocaBytes ((20)) $ \buf ->
w (ftTag ft) $ \(tbuf,tsiz) ->
w (ftEncoding ft) $ \(ebuf,esiz) -> do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) buf (0::ULONG)
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) buf tsiz
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) buf tbuf
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) buf esiz
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) buf ebuf
act buf
where
w v a = case v of
Nothing -> a (nullPtr, 0)
Just x -> withCAStringLen 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 = ((24))
len = length att
write act _ [] = act
write act buf (att:y) =
withCAString (attPath att) $ \path ->
maybeWith withFileTag (attTag att) $ \tag ->
withCAString (maybe (attPath att) id (attName att)) $ \name -> do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) buf (0::ULONG)
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) buf (attFlag att)
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) buf (maybe 0xffffffff id $ attPosition att)
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) buf path
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) buf name
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) 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 =
withCAString (msgSubject m) $ \subject ->
withCAString (msgBody m) $ \body ->
maybeWith withCAString (msgType m) $ \message_type ->
maybeWith withCAString (msgDate m) $ \date ->
maybeWith withCAString (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 ((48)) $ \buf -> do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) buf (0::ULONG)
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) buf subject
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) buf body
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) buf message_type
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) buf date
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) buf conv_id
((\hsc_ptr -> pokeByteOff hsc_ptr 24)) buf (msgFlags m)
((\hsc_ptr -> pokeByteOff hsc_ptr 28)) buf from
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) buf (fromIntegral rlen :: ULONG)
((\hsc_ptr -> pokeByteOff hsc_ptr 36)) buf rbuf
((\hsc_ptr -> pokeByteOff hsc_ptr 40)) buf alen
((\hsc_ptr -> pokeByteOff hsc_ptr 44)) 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