---------------------------------------------------------------------- -- | -- Module : Network.HaskellNet.IMAP -- Copyright : (c) Jun Mukai 2006 -- License : BSD-style (see the file LICENSE) -- -- Maintainer : mukai@jmuk.org -- Stability : stable -- Portability : portable -- -- IMAP client implementation -- module Network.HaskellNet.IMAP ( -- * connection type and corresponding actions IMAPConnection , mailbox, exists, recent , flags, permanentFlags, isWritable, isFlagWritable , uidNext, uidValidity , stream , connectIMAP, connectIMAPPort, connectStream -- * IMAP commands -- ** any state commands , noop, capability, logout -- ** not authenticated state commands , login, authenticate -- ** autenticated state commands , select, examine, create, delete, rename , subscribe, unsubscribe , list, lsub, status, append -- ** selected state commands , check, close, expunge , search, store, copy -- * fetch commands , fetch, fetchHeader, fetchSize, fetchHeaderFields, fetchHeaderFieldsNot , fetchFlags, fetchR, fetchByString, fetchByStringR -- * other types , Flag(..), Attribute(..), MailboxStatus(..) , SearchQuery(..), FlagsQuery(..) ) where import Network import Network.HaskellNet.BSStream import Network.HaskellNet.Auth hiding (auth, login) import qualified Network.HaskellNet.Auth as A import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Digest.MD5 import Control.Monad import Control.Monad.Writer import System.IO import System.Time import Data.IORef import Data.Maybe import Data.Word import Data.List hiding (delete) import Data.Char import Text.IMAPParsers hiding (exists, recent) import Text.Packrat.Parse (Result) ---------------------------------------------------------------------- -- connection type and corresponding functions data BSStream s => IMAPConnection s = IMAPC s (IORef MailboxInfo) (IORef Int) mailbox :: BSStream s => IMAPConnection s -> IO Mailbox mailbox (IMAPC _ mbox _) = fmap _mailbox $ readIORef mbox exists, recent :: BSStream s => IMAPConnection s -> IO Integer exists (IMAPC _ mbox _) = fmap _exists $ readIORef mbox recent (IMAPC _ mbox _) = fmap _recent $ readIORef mbox flags, permanentFlags :: BSStream s => IMAPConnection s -> IO [Flag] flags (IMAPC _ mbox _) = fmap _flags $ readIORef mbox permanentFlags (IMAPC _ mbox _) = fmap _permanentFlags $ readIORef mbox isWritable, isFlagWritable :: BSStream s => IMAPConnection s -> IO Bool isWritable (IMAPC _ mbox _) = fmap _isWritable $ readIORef mbox isFlagWritable (IMAPC _ mbox _) = fmap _isFlagWritable $ readIORef mbox uidNext, uidValidity :: BSStream s => IMAPConnection s -> IO UID uidNext (IMAPC _ mbox _) = fmap _uidNext $ readIORef mbox uidValidity (IMAPC _ mbox _) = fmap _uidValidity $ readIORef mbox stream :: BSStream s => IMAPConnection s -> s stream (IMAPC s _ _) = s -- suffixed by `s' data SearchQuery = ALLs | FLAG Flag | UNFLAG Flag | BCCs String | BEFOREs CalendarTime | BODYs String | CCs String | FROMs String | HEADERs String String | LARGERs Integer | NEWs | NOTs SearchQuery | OLDs | ONs CalendarTime | ORs SearchQuery SearchQuery | SENTBEFOREs CalendarTime | SENTONs CalendarTime | SENTSINCEs CalendarTime | SINCEs CalendarTime | SMALLERs Integer | SUBJECTs String | TEXTs String | TOs String | UIDs [UID] instance Show SearchQuery where showsPrec d q = showParen (d>app_prec) $ showString $ showQuery q where app_prec = 10 showQuery ALLs = "ALL" showQuery (FLAG f) = showFlag f showQuery (UNFLAG f) = "UN" ++ showFlag f showQuery (BCCs addr) = "BCC " ++ addr showQuery (BEFOREs t) = "BEFORE " ++ dateToStringIMAP t showQuery (BODYs s) = "BODY " ++ s showQuery (CCs addr) = "CC " ++ addr showQuery (FROMs addr) = "FROM " ++ addr showQuery (HEADERs f v) = "HEADER " ++ f ++ " " ++ v showQuery (LARGERs siz) = "LARGER {" ++ show siz ++ "}" showQuery NEWs = "NEW" showQuery (NOTs q) = "NOT " ++ show q showQuery OLDs = "OLD" showQuery (ONs t) = "ON " ++ dateToStringIMAP t showQuery (ORs q1 q2) = "OR " ++ show q1 ++ " " ++ show q2 showQuery (SENTBEFOREs t) = "SENTBEFORE " ++ dateToStringIMAP t showQuery (SENTONs t) = "SENTON " ++ dateToStringIMAP t showQuery (SENTSINCEs t) = "SENTSINCE " ++ dateToStringIMAP t showQuery (SINCEs t) = "SINCE " ++ dateToStringIMAP t showQuery (SMALLERs siz) = "SMALLER {" ++ show siz ++ "}" showQuery (SUBJECTs s) = "SUBJECT " ++ s showQuery (TEXTs s) = "TEXT " ++ s showQuery (TOs addr) = "TO " ++ addr showQuery (UIDs uids) = concat $ intersperse "," $ map show uids showFlag Seen = "SEEN" showFlag Answered = "ANSWERED" showFlag Flagged = "FLAGGED" showFlag Deleted = "DELETED" showFlag Draft = "DRAFT" showFlag Recent = "RECENT" showFlag (Keyword s) = "KEYWORD " ++ s data FlagsQuery = ReplaceFlags [Flag] | PlusFlags [Flag] | MinusFlags [Flag] ---------------------------------------------------------------------- -- establish connection connectIMAPPort :: String -> PortNumber -> IO (IMAPConnection Handle) connectIMAPPort hostname port = connectTo hostname (PortNumber port) >>= connectStream connectIMAP :: String -> IO (IMAPConnection Handle) connectIMAP hostname = connectIMAPPort hostname 143 connectStream :: BSStream s => s -> IO (IMAPConnection s) connectStream s = do msg <- bsGetLine s unless (and $ BS.zipWith (==) msg (BS.pack "* OK")) $ fail "cannot connect to the server" mbox <- newIORef emptyMboxInfo c <- newIORef 0 return $ IMAPC s mbox c emptyMboxInfo = MboxInfo "" 0 0 [] [] False False 0 0 ---------------------------------------------------------------------- -- normal send commands sendCommand' :: BSStream s => IMAPConnection s -> String -> IO ByteString sendCommand' (IMAPC s mbox nr) cmdstr = do num <- readIORef nr bsPutCrLf s $ BS.pack $ show6 num ++ " " ++ cmdstr modifyIORef nr (+1) getResponse s show6 n | n > 100000 = show n | n > 10000 = '0' : show n | n > 1000 = "00" ++ show n | n > 100 = "000" ++ show n | n > 10 = "0000" ++ show n | otherwise = "00000" ++ show n sendCommand :: BSStream s => IMAPConnection s -> String -> (RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, v)) -> IO v sendCommand imapc@(IMAPC _ mbox nr) cmdstr pFunc = do num <- readIORef nr buf <- sendCommand' imapc cmdstr let (resp, mboxUp, value) = eval pFunc (show6 num) buf case resp of OK _ _ -> do mboxUpdate mbox $ mboxUp return value NO _ msg -> fail ("NO: " ++ msg) BAD _ msg -> fail ("BAD: " ++ msg) PREAUTH _ msg -> fail ("preauth: " ++ msg) getResponse :: BSStream s => s -> IO ByteString getResponse s = fmap unlinesCRLF getLs where unlinesCRLF = BS.concat . concatMap (:[crlf]) getLs = do l <- fmap strip $ bsGetLine s case () of _ | isLiteral l -> do l' <- getLiteral l (getLitLen l) ls <- getLs return (l' : ls) | isTagged l -> fmap (l:) getLs | otherwise -> return [l] getLiteral l len = do lit <- bsGet s len l2 <- fmap strip $ bsGetLine s let l' = BS.concat [l, crlf, lit, l2] if isLiteral l2 then getLiteral l' (getLitLen l2) else return l' crlf = BS.pack "\r\n" isLiteral l = BS.last l == '}' && BS.last (fst (BS.spanEnd isDigit (BS.init l))) == '{' getLitLen = read . BS.unpack . snd . BS.spanEnd isDigit . BS.init isTagged l = BS.head l == '*' && BS.head (BS.tail l) == ' ' mboxUpdate :: IORef MailboxInfo -> MboxUpdate -> IO () mboxUpdate mbox (MboxUpdate exists recent) = do when (isJust exists) $ do mb <- readIORef mbox writeIORef mbox (mb { _exists = e }) when (isJust recent) $ do mb <- readIORef mbox writeIORef mbox (mb { _recent = r }) where e = fromJust exists r = fromJust recent ---------------------------------------------------------------------- -- IMAP commands -- noop :: BSStream s => IMAPConnection s -> IO () noop conn@(IMAPC s mbox _) = sendCommand conn "NOOP" pNone capability :: BSStream s => IMAPConnection s -> IO [String] capability conn = sendCommand conn "CAPABILITY" pCapability logout :: BSStream s => IMAPConnection s -> IO () logout conn@(IMAPC s _ _) = do bsPutCrLf s $ BS.pack "a0001 LOGOUT" bsClose s login :: BSStream s => IMAPConnection s -> UserName -> Password -> IO () login conn user pass = sendCommand conn ("LOGIN " ++ user ++ " " ++ pass) pNone select, examine, create, delete :: BSStream s => IMAPConnection s -> Mailbox -> IO () _select cmd conn@(IMAPC s mbox _) mboxName = do mbox' <- sendCommand conn (cmd ++ mboxName) pSelect writeIORef mbox (mbox' { _mailbox = mboxName }) authenticate :: BSStream s => IMAPConnection s -> AuthType -> UserName -> Password -> IO () authenticate conn@(IMAPC s mbox nr) LOGIN user pass = do num <- readIORef nr sendCommand' conn "AUTHENTICATE LOGIN" bsPutCrLf s $ BS.pack userB64 bsGetLine s bsPutCrLf s $ BS.pack passB64 buf <- getResponse s let (resp, mboxUp, value) = eval pNone (show6 num) buf case resp of OK _ _ -> do mboxUpdate mbox $ mboxUp return value NO _ msg -> fail ("NO: " ++ msg) BAD _ msg -> fail ("BAD: " ++ msg) PREAUTH _ msg -> fail ("preauth: " ++ msg) where (userB64, passB64) = A.login user pass authenticate conn@(IMAPC s mbox nr) at user pass = do num <- readIORef nr c <- sendCommand' conn $ "AUTHENTICATE " ++ show at let challenge = if BS.take 2 c == BS.pack "+ " then b64Decode $ BS.unpack $ head $ dropWhile (isSpace . BS.last) $ BS.inits $ BS.drop 2 c else "" bsPutCrLf s $ BS.pack $ A.auth at challenge user pass buf <- getResponse s let (resp, mboxUp, value) = eval pNone (show6 num) buf case resp of OK _ _ -> do mboxUpdate mbox $ mboxUp return value NO _ msg -> fail ("NO: " ++ msg) BAD _ msg -> fail ("BAD: " ++ msg) PREAUTH _ msg -> fail ("preauth: " ++ msg) select = _select "SELECT " examine = _select "EXAMINE " create conn mboxname = sendCommand conn ("CREATE " ++ mboxname) pNone delete conn mboxname = sendCommand conn ("DELETE " ++ mboxname) pNone rename :: BSStream s => IMAPConnection s -> Mailbox -> Mailbox -> IO () rename conn mboxorg mboxnew = sendCommand conn ("RENAME " ++ mboxorg ++ " " ++ mboxnew) pNone subscribe, unsubscribe :: BSStream s => IMAPConnection s -> Mailbox -> IO () subscribe conn mboxname = sendCommand conn ("SUBSCRIBE " ++ mboxname) pNone unsubscribe conn mboxname = sendCommand conn ("UNSUBSCRIBE " ++ mboxname) pNone list, lsub :: BSStream s => IMAPConnection s -> IO [([Attribute], Mailbox)] list conn = fmap (map (\(a, _, m) -> (a, m))) $ listFull conn "\"\"" "*" lsub conn = fmap (map (\(a, _, m) -> (a, m))) $ lsubFull conn "\"\"" "*" listPat, lsubPat :: BSStream s => IMAPConnection s -> String -> IO [([Attribute], String, Mailbox)] listPat conn pat = listFull conn "\"\"" pat lsubPat conn pat = lsubFull conn "\"\"" pat listFull, lsubFull :: BSStream s => IMAPConnection s -> String -> String -> IO [([Attribute], String, Mailbox)] listFull conn ref pat = sendCommand conn (unwords ["LIST", ref, pat]) pList lsubFull conn ref pat = sendCommand conn (unwords ["LSUB", ref, pat]) pLsub status :: BSStream s => IMAPConnection s -> Mailbox -> [MailboxStatus] -> IO [(MailboxStatus, Integer)] status conn mbox stats = sendCommand conn ("STATUS " ++ mbox ++ " (" ++ (unwords $ map show stats) ++ ")") pStatus append :: BSStream s => IMAPConnection s -> Mailbox -> ByteString -> IO () append conn mbox mailData = appendFull conn mbox mailData [] Nothing appendFull :: BSStream s => IMAPConnection s -> Mailbox -> ByteString -> [Flag] -> Maybe CalendarTime -> IO () appendFull conn@(IMAPC s mbInfo nr) mbox mailData flags time = do num <- readIORef nr buf <- sendCommand' conn (unwords ["APPEND", mbox , fstr, tstr, "{" ++ show len ++ "}"]) unless (BS.null buf || (BS.head buf /= '+')) $ fail "illegal server response" mapM_ (bsPutCrLf s) mailLines buf <- getResponse s let (resp, mboxUp, ()) = eval pNone (show6 num) buf case resp of OK _ _ -> mboxUpdate mbInfo mboxUp NO _ msg -> fail ("NO: "++msg) BAD _ msg -> fail ("BAD: "++msg) PREAUTH _ msg -> fail ("PREAUTH: "++msg) where mailLines = BS.lines mailData len = sum $ map ((2+) . BS.length) mailLines tstr = maybe "" show time fstr = unwords $ map show flags check :: BSStream s => IMAPConnection s -> IO () check conn = sendCommand conn "CHECK" pNone close :: BSStream s => IMAPConnection s -> IO () close conn@(IMAPC s mbox _) = do sendCommand conn "CLOSE" pNone writeIORef mbox emptyMboxInfo expunge :: BSStream s => IMAPConnection s -> IO [Integer] expunge conn = sendCommand conn "EXPUNGE" pExpunge search :: BSStream s => IMAPConnection s -> [SearchQuery] -> IO [UID] search conn queries = searchCharset conn "" queries searchCharset :: BSStream s => IMAPConnection s -> Charset -> [SearchQuery] -> IO [UID] searchCharset conn charset queries = sendCommand conn ("UID SEARCH " ++ (if not . null $ charset then charset ++ " " else "") ++ unwords (map show queries)) pSearch fetch, fetchHeader :: BSStream s => IMAPConnection s -> UID -> IO ByteString fetch conn uid = do lst <- fetchByString conn uid "BODY[]" return $ maybe BS.empty BS.pack $ lookup "BODY[]" lst fetchHeader conn uid = do lst <- fetchByString conn uid "BODY[HEADER]" return $ maybe BS.empty BS.pack $ lookup "BODY[HEADER]" lst fetchSize :: BSStream s => IMAPConnection s -> UID -> IO Int fetchSize conn uid = do lst <- fetchByString conn uid "RFC822.SIZE" return $ maybe 0 read $ lookup "RFC822.SIZE" lst fetchHeaderFields, fetchHeaderFieldsNot :: BSStream s => IMAPConnection s -> UID -> [String] -> IO ByteString fetchHeaderFields conn uid hs = do lst <- fetchByString conn uid ("BODY[HEADER.FIELDS "++unwords hs++"]") return $ maybe BS.empty BS.pack $ lookup ("BODY[HEADER.FIELDS "++unwords hs++"]") lst fetchHeaderFieldsNot conn uid hs = do lst <- fetchByString conn uid ("BODY[HEADER.FIELDS.NOT "++unwords hs++"]") return $ maybe BS.empty BS.pack $ lookup ("BODY[HEADER.FIELDS.NOT "++unwords hs++"]") lst fetchFlags :: BSStream s => IMAPConnection s -> UID -> IO [Flag] fetchFlags conn uid = do lst <- fetchByString conn uid "FLAGS" return $ getFlags $ lookup "FLAGS" lst where getFlags Nothing = [] getFlags (Just s) = eval' dvFlags "" s fetchR :: BSStream s => IMAPConnection s -> (UID, UID) -> IO [(UID, ByteString)] fetchR conn r = do lst <- fetchByStringR conn r "BODY[]" return $ map (\(uid, vs) -> (uid, maybe BS.empty BS.pack $ lookup "BODY[]" vs)) lst fetchByString :: BSStream s => IMAPConnection s -> UID -> String -> IO [(String, String)] fetchByString conn uid command = do lst <- fetchCommand conn ("UID FETCH "++show uid++" "++command) id return $ snd $ head lst fetchByStringR :: BSStream s => IMAPConnection s -> (UID, UID) -> String -> IO [(UID, [(String, String)])] fetchByStringR conn (s, e) command = fetchCommand conn ("UID FETCH "++show s++":"++show e++" "++command) proc where proc (n, ps) = (maybe (toEnum (fromIntegral n)) read (lookup "UID" ps), ps) fetchCommand conn command proc = fmap (map proc) $ sendCommand conn command pFetch storeFull :: BSStream s => IMAPConnection s -> String -> FlagsQuery -> Bool -> IO [(UID, [Flag])] storeFull conn uidstr query isSilent = fetchCommand conn ("UID STORE " ++ uidstr ++ flags query) procStore where fstrs fs = "(" ++ (concat $ intersperse " " $ map show fs) ++ ")" toFStr s fstrs = s ++ (if isSilent then ".SILENT" else "") ++ " " ++ fstrs flags (ReplaceFlags fs) = toFStr "FLAGS" $ fstrs fs flags (PlusFlags fs) = toFStr "+FLAGS" $ fstrs fs flags (MinusFlags fs) = toFStr "-FLAGS" $ fstrs fs procStore (n, ps) = (maybe (toEnum (fromIntegral n)) read (lookup "UID" ps) ,maybe [] (eval' dvFlags "") (lookup "FLAG" ps)) store :: BSStream s => IMAPConnection s -> UID -> FlagsQuery -> IO () storeR :: BSStream s => IMAPConnection s -> (UID, UID) -> FlagsQuery -> IO () store conn i q = storeFull conn (show i) q True >> return () storeR conn (s, e) q = storeFull conn (show s++":"++show e) q True >> return () -- storeResults is used without .SILENT, so that its response contains its result flags storeResults :: BSStream s => IMAPConnection s -> UID -> FlagsQuery -> IO [Flag] storeResultsR :: BSStream s => IMAPConnection s -> (UID, UID) -> FlagsQuery -> IO [(UID, [Flag])] storeResults conn i q = storeFull conn (show i) q False >>= return . snd . head storeResultsR conn (s, e) q = storeFull conn (show s++":"++show e) q False copy :: BSStream s => IMAPConnection s -> UID -> Mailbox -> IO () copyR :: BSStream s => IMAPConnection s -> (UID, UID) -> Mailbox -> IO () copyFull conn uidStr mbox = sendCommand conn ("UID COPY " ++ uidStr ++ " " ++ mbox) pNone copy conn uid mbox = copyFull conn (show uid) mbox copyR conn (s, e) mbox = copyFull conn (show s++":"++show e) mbox ---------------------------------------------------------------------- -- auxialiary functions dateToStringIMAP :: CalendarTime -> String dateToStringIMAP date = concat $ intersperse "-" [show2 $ ctDay date , showMonth $ ctMonth date , show $ ctYear date] where show2 n | n < 10 = '0' : show n | otherwise = show n showMonth January = "Jan" showMonth February = "Feb" showMonth March = "Mar" showMonth April = "Apr" showMonth May = "May" showMonth June = "Jun" showMonth July = "Jul" showMonth August = "Aug" showMonth September = "Sep" showMonth October = "Oct" showMonth November = "Nov" showMonth December = "Dec" strip :: ByteString -> ByteString strip = fst . BS.spanEnd isSpace . BS.dropWhile isSpace