diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,9 @@ +0.6.1.0 (2023-06-27) + - fixed bug with wrong IMAP header decoding ([Issue 89](https://github.com/qnikst/HaskellNet/issues/89)) + Thanks to William Arteroi (@wwmoraes) and Nathan Collins (@ntc2) + - added support for OAuth2 authorization + Thanks to @paumr. + 0.6.0.1 (2022-05-17) - GHC 9.0+ support diff --git a/HaskellNet.cabal b/HaskellNet.cabal --- a/HaskellNet.cabal +++ b/HaskellNet.cabal @@ -6,7 +6,7 @@ Full examples can be found in the . Additional documentation on the major updates can be found in the file -Version: 0.6.0.2 +Version: 0.6.1.2 Copyright: (c) 2006 Jun Mukai Author: Jun Mukai Maintainer: Alexander Vershilov , @@ -19,12 +19,11 @@ Cabal-version: 1.22 Build-type: Simple Tested-with: - GHC ==8.4.4 - || ==8.6.5 - || ==8.8.4 + GHC ==8.8.4 || ==8.10.7 || ==9.0.2 - || ==9.2.2 + || ==9.2.5 + || ==9.4.4 Extra-Source-Files: CHANGELOG @@ -70,15 +69,15 @@ Build-Depends: base >= 4.3 && < 4.18, network >= 2.6.3.1 && < 3.2, - mtl, - bytestring >=0.10.2, - pretty, - array, - cryptohash-md5, + mtl >= 2.2.2 && < 2.3, + bytestring >=0.10.2 && < 0.12, + pretty >= 1.1.3 && < 1.2, + array >= 0.5 && < 0.6, + cryptohash-md5 >= 0.11 && < 0.12, base64 < 0.5, - old-time, - mime-mail >= 0.4.7 && < 0.6, - text + old-time >= 1.0 && < 1.2, + mime-mail >= 0.4 && < 0.6, + text >= 1.0 && < 3 if !impl(ghc >= 8.0) Build-depends: fail >= 4.9.0.0 && <4.10 diff --git a/src/Network/HaskellNet/Auth.hs b/src/Network/HaskellNet/Auth.hs --- a/src/Network/HaskellNet/Auth.hs +++ b/src/Network/HaskellNet/Auth.hs @@ -24,6 +24,7 @@ data AuthType = PLAIN | LOGIN | CRAM_MD5 + | XOAUTH2 deriving Eq instance Show AuthType where @@ -32,6 +33,7 @@ showMain PLAIN = "PLAIN" showMain LOGIN = "LOGIN" showMain CRAM_MD5 = "CRAM-MD5" + showMain XOAUTH2 = "XOAUTH2" b64Encode :: String -> String b64Encode = T.unpack . encode . T.pack @@ -86,3 +88,4 @@ auth PLAIN _ u p = plain u p auth LOGIN _ u p = let (u', p') = login u p in unwords [u', p'] auth CRAM_MD5 c u p = cramMD5 c u p +auth XOAUTH2 _ u p = b64Encode $ "user=" ++ u ++ "\001auth=" ++ p ++ "\001\001" diff --git a/src/Network/HaskellNet/IMAP.hs b/src/Network/HaskellNet/IMAP.hs --- a/src/Network/HaskellNet/IMAP.hs +++ b/src/Network/HaskellNet/IMAP.hs @@ -8,7 +8,7 @@ -- ** autenticated state commands , select, examine, create, delete, rename , subscribe, unsubscribe - , list, lsub, status, append + , list, lsub, status, append, appendFull -- ** selected state commands , check, close, expunge , search, store, copy @@ -70,6 +70,7 @@ | SUBJECTs String | TEXTs String | TOs String + | XGMRAW String | UIDs [UID] @@ -99,6 +100,7 @@ showQuery (SUBJECTs s) = "SUBJECT " ++ s showQuery (TEXTs s) = "TEXT " ++ s showQuery (TOs addr) = "TO " ++ addr + showQuery (XGMRAW s) = "X-GM-RAW " ++ s showQuery (UIDs uids) = concat $ intersperse "," $ map show uids showFlag Seen = "SEEN" @@ -112,6 +114,9 @@ data FlagsQuery = ReplaceFlags [Flag] | PlusFlags [Flag] | MinusFlags [Flag] + | ReplaceGmailLabels [GmailLabel] + | PlusGmailLabels [GmailLabel] + | MinusGmailLabels [GmailLabel] ---------------------------------------------------------------------- -- establish connection @@ -213,10 +218,10 @@ return buf' let (resp, mboxUp, value) = eval pNone (show6 num) buf case resp of - OK _ _ -> do mboxUpdate conn mboxUp - return value - NO _ msg -> fail ("NO: " ++ msg) - BAD _ msg -> fail ("BAD: " ++ msg) + OK _ _ -> do mboxUpdate conn mboxUp + return value + NO _ msg -> fail ("NO: " ++ msg) + BAD _ msg -> fail ("BAD: " ++ msg) PREAUTH _ msg -> fail ("preauth: " ++ msg) noop :: IMAPConnection -> IO () @@ -332,13 +337,13 @@ buf2 <- getResponse $ stream conn let (resp, mboxUp, ()) = eval pNone (show6 num) buf2 case resp of - OK _ _ -> mboxUpdate conn mboxUp - NO _ msg -> fail ("NO: "++msg) - BAD _ msg -> fail ("BAD: "++msg) + OK _ _ -> mboxUpdate conn 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 + tstr = maybe "" ((" "++) . datetimeToStringIMAP) time fstr = maybe "" ((" ("++) . (++")") . unwords . map show) flags' check :: IMAPConnection -> IO () @@ -377,26 +382,26 @@ fetchSize :: IMAPConnection -> UID -> IO Int fetchSize conn uid = do lst <- fetchByString conn uid "RFC822.SIZE" - return $ maybe 0 read $ lookup' "RFC822.SIZE" lst + return $ maybe 0 read $ lookup "RFC822.SIZE" lst fetchHeaderFields :: IMAPConnection -> 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 + do let fetchCmd = "BODY[HEADER.FIELDS ("++unwords hs++")]" + lst <- fetchByString conn uid fetchCmd + return $ maybe BS.empty BS.pack $ lookup' fetchCmd lst fetchHeaderFieldsNot :: IMAPConnection -> UID -> [String] -> IO ByteString fetchHeaderFieldsNot conn uid hs = - do let fetchCmd = "BODY[HEADER.FIELDS.NOT "++unwords hs++"]" + do let fetchCmd = "BODY[HEADER.FIELDS.NOT ("++unwords hs++")]" lst <- fetchByString conn uid fetchCmd return $ maybe BS.empty BS.pack $ lookup' fetchCmd lst fetchFlags :: IMAPConnection -> UID -> IO [Flag] fetchFlags conn uid = do lst <- fetchByString conn uid "FLAGS" - return $ getFlags $ lookup' "FLAGS" lst + return $ getFlags $ lookup "FLAGS" lst where getFlags Nothing = [] getFlags (Just s) = eval' dvFlags "" s @@ -431,9 +436,12 @@ where fstrs fs = "(" ++ (concat $ intersperse " " $ map show fs) ++ ")" toFStr s fstrs' = s ++ (if isSilent then ".SILENT" else "") ++ " " ++ fstrs' - flgs (ReplaceFlags fs) = toFStr "FLAGS" $ fstrs fs - flgs (PlusFlags fs) = toFStr "+FLAGS" $ fstrs fs - flgs (MinusFlags fs) = toFStr "-FLAGS" $ fstrs fs + flgs (ReplaceGmailLabels ls) = toFStr "X-GM-LABELS" $ fstrs ls + flgs (PlusGmailLabels ls) = toFStr "+X-GM-LABELS" $ fstrs ls + flgs (MinusGmailLabels ls) = toFStr "-X-GM-LABELS" $ fstrs ls + flgs (ReplaceFlags fs) = toFStr "FLAGS" $ fstrs fs + flgs (PlusFlags fs) = toFStr "+FLAGS" $ fstrs fs + flgs (MinusFlags fs) = toFStr "-FLAGS" $ fstrs fs procStore (n, ps) = (maybe (toEnum (fromIntegral n)) read (lookup' "UID" ps) ,maybe [] (eval' dvFlags "") (lookup' "FLAG" ps)) @@ -452,25 +460,55 @@ ---------------------------------------------------------------------- -- auxialiary functions +showMonth :: Month -> String +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" + +show2 :: Int -> String +show2 n | n < 10 = '0' : show n + | otherwise = show n + + +show4 :: (Ord a, Num a, Show a) => a -> String +show4 n | n > 1000 = show n + | n > 100 = '0' : show n + | n > 10 = "00" ++ show n + | otherwise = "000" ++ show n + 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" +timeToStringIMAP :: CalendarTime -> String +timeToStringIMAP c = concat + $ intersperse ":" + $ fmap show2 [ctHour c, ctMin c, ctSec c] +-- Convert CalenarTime to "date-time" string per RFC3501 +datetimeToStringIMAP :: CalendarTime -> String +datetimeToStringIMAP c = + "\"" + ++ dateToStringIMAP c + ++ " " + ++ timeToStringIMAP c + ++ " " + ++ zone (ctTZ c) + ++ "\"" + where + zone s = + (if s>=0 then "+" else "-") ++ + show4 (s `div` 3600) + strip :: ByteString -> ByteString strip = fst . BS.spanEnd isSpace . BS.dropWhile isSpace @@ -482,10 +520,10 @@ lookup' :: String -> [(String, b)] -> Maybe b lookup' _ [] = Nothing -lookup' q ((k,v):xs) | q == lastWord k = return v +lookup' q ((k,v):xs) | q == query k = return v | otherwise = lookup' q xs where - lastWord = last . words + query = unwords . drop 2 . words -- TODO: This is just a first trial solution for this stack overflow question: -- http://stackoverflow.com/questions/26183675/error-when-fetching-subject-from-email-using-haskellnets-imap diff --git a/src/Network/HaskellNet/IMAP/Types.hs b/src/Network/HaskellNet/IMAP/Types.hs --- a/src/Network/HaskellNet/IMAP/Types.hs +++ b/src/Network/HaskellNet/IMAP/Types.hs @@ -1,5 +1,6 @@ module Network.HaskellNet.IMAP.Types ( MailboxName + , GmailLabel , UID , Charset , MailboxInfo(..) @@ -28,6 +29,7 @@ type MailboxName = String type UID = Word64 type Charset = String +type GmailLabel = String data MailboxInfo = MboxInfo { _mailbox :: MailboxName , _exists :: Integer