imap 0.2.0.0 → 0.2.0.1

raw patch · 4 files changed

+390/−1 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

imap.cabal +4/−1
src/Network/IMAP/Parsers/Fetch.hs +115/−0
src/Network/IMAP/Parsers/Untagged.hs +168/−0
src/Network/IMAP/Parsers/Utils.hs +103/−0

imap.cabal view

@@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/  name:                imap-version:             0.2.0.0+version:             0.2.0.1 synopsis:            An efficient IMAP client library, with SSL and streaming license:             BSD3 license-file:        LICENSE@@ -97,6 +97,9 @@   exposed-modules:     Network.IMAP     Network.IMAP.Parsers+    Network.IMAP.Parsers.Fetch+    Network.IMAP.Parsers.Untagged+    Network.IMAP.Parsers.Utils     Network.IMAP.RequestWatcher     Network.IMAP.Types     Network.IMAP.Utils

+ src/Network/IMAP/Parsers/Fetch.hs view

@@ -0,0 +1,115 @@+module Network.IMAP.Parsers.Fetch where++import Network.IMAP.Types+import Network.IMAP.Parsers.Utils+import Network.IMAP.Parsers.Untagged (parseFlags)++import Data.Attoparsec.ByteString+import qualified Data.Attoparsec.ByteString as AP+import Data.Word8+import qualified Data.ByteString.Char8 as BSC+import Data.Maybe (fromJust, isNothing)+import Data.Either.Combinators (isRight, fromRight', fromLeft')++import Control.Applicative+import Control.Monad (liftM)+++parseFetch :: Parser (Either ErrorMessage CommandResult)+parseFetch = do+  string "* "+  msgId <- liftM toInt $ AP.takeWhile1 isDigit+  let msgId' = msgId >>= Right . MessageId+  string " FETCH ("++  parsedFetch <- parseSpecifiers++  let allInOneEither = sequence $ msgId':parsedFetch+  return $ liftM (Untagged . Fetch) allInOneEither++parseSpecifiers :: Parser [Either ErrorMessage UntaggedResult]+parseSpecifiers = do+  nextChar <- AP.peekWord8+  if isNothing nextChar || (fromJust nextChar == _cr)+    then return []+    else do+      nextRes <- (Right <$> parseEnvelope) <|>+                  parseFlags <|>+                  (Right <$> parseInternalDate) <|>+                  parseNumber Size "RFC822.SIZE" "" <|>+                  ((string "BODY[" <|> string "RFC822.HEADER"+                   <|> string "RFC822.TEXT" <|> string "RFC822") *> parseBody) <|>+                  parseNumber UID "UID" "" <|>+                  Right <$> parseBodyStructure++      (nextRes:) <$> (AP.anyWord8 *> parseSpecifiers)++parseInternalDate :: Parser UntaggedResult+parseInternalDate = liftM InternalDate $ string "INTERNALDATE " *> parseQuotedText++parseBody :: Parser (Either ErrorMessage UntaggedResult)+parseBody = do+  AP.takeWhile (/= _braceleft)+  word8 _braceleft+  size <- AP.takeWhile1 isDigit+  string "}\r\n"++  let parsedSize = toInt size+  if isRight parsedSize+    then do+      msg <- AP.take (fromRight' parsedSize)+      return . Right . Body $ msg+    else return . Left $ fromLeft' parsedSize++parseBodyStructure :: Parser UntaggedResult+parseBodyStructure = do+  string "BODYSTRUCTURE " <|> string "BODY "+  structure <- eatUntilClosingParen+  return . BodyStructure $ BSC.snoc structure ')'+++parseEnvelope :: Parser UntaggedResult+parseEnvelope = do+  string "ENVELOPE ("+  date <- nilOrValue parseQuotedText+  word8 _space++  subject <- nilOrValue parseQuotedText+  word8 _space++  from <- nilOrValue parseEmailList+  word8 _space++  sender <- nilOrValue parseEmailList+  word8 _space++  replyTo <- nilOrValue parseEmailList+  word8 _space++  to <- nilOrValue parseEmailList+  word8 _space++  cc <- nilOrValue parseEmailList+  word8 _space++  bcc <- nilOrValue parseEmailList+  word8 _space++  inReplyTo <- nilOrValue parseQuotedText+  word8 _space++  messageId <- nilOrValue parseQuotedText+  string ")"++  return Envelope {+    eDate = date,+    eSubject = subject,+    eFrom = from,+    eSender = sender,+    eReplyTo = replyTo,+    eTo = to,+    eCC = cc,+    eBCC = bcc,+    eInReplyTo = inReplyTo,+    eMessageId = messageId+  }

+ src/Network/IMAP/Parsers/Untagged.hs view

@@ -0,0 +1,168 @@+module Network.IMAP.Parsers.Untagged where++import Network.IMAP.Types+import Network.IMAP.Parsers.Utils++import Data.Attoparsec.ByteString+import qualified Data.Attoparsec.ByteString as AP+import Data.Word8+import qualified Data.Text as T+import qualified Data.Text.Read as TR+import Data.Text.Encoding (decodeUtf8)+import Data.Either.Combinators (mapBoth, mapRight)++import Control.Applicative+import Control.Monad (mzero, liftM, (>=>))++parseOk :: Parser UntaggedResult+parseOk = do+  string "OK "+  contents <- AP.takeWhile (/= _cr)+  return . OKResult . decodeUtf8 $ contents++parseFlag :: Parser Flag+parseFlag = do+  word8 _backslash+  flagName <- takeWhile1 (\c -> isLetter c || c == _asterisk)+  case flagName of+            "Seen" -> return FSeen+            "Answered" -> return FAnswered+            "Flagged" -> return FFlagged+            "Deleted" -> return FDeleted+            "Draft" -> return FDraft+            "Recent" -> return FRecent+            "*" -> return FAny+            _ -> mzero++parseWeirdFlag :: Parser Flag+parseWeirdFlag = do+  flagText <- AP.takeWhile1 (\c -> isLetter c || c == _dollar)+  return . FOther . decodeUtf8 $ flagText++parseFlagList :: Parser [Flag]+parseFlagList = word8 _parenleft *>+                (parseFlag <|> parseWeirdFlag) `sepBy` word8 _space+                <* word8 _parenright++parseFlags :: Parser (Either ErrorMessage UntaggedResult)+parseFlags = Right . Flags <$> (string "FLAGS " *> parseFlagList)++parseExists :: Parser (Either ErrorMessage UntaggedResult)+parseExists = parseNumber Exists "" "EXISTS"++parseBye :: Parser UntaggedResult+parseBye = string "BYE" *> AP.takeWhile (/= _cr) *> return Bye++parseRecent :: Parser (Either ErrorMessage UntaggedResult)+parseRecent = parseNumber Recent "" "RECENT"++parseOkResp :: Parser a -> Parser a+parseOkResp innerParser = string "OK [" *> innerParser <* string "]"++parseUnseen :: Parser (Either ErrorMessage UntaggedResult)+parseUnseen = parseOkResp $+  (toInt >=> (Right . Unseen)) <$>+  (string "UNSEEN " *> takeWhile1 isDigit)++parsePermanentFlags :: Parser UntaggedResult+parsePermanentFlags = parseOkResp $+  PermanentFlags <$> (string "PERMANENTFLAGS " *> parseFlagList)++parseUidNext :: Parser (Either ErrorMessage UntaggedResult)+parseUidNext = parseOkResp $ parseNumber UIDNext "UIDNEXT" ""++parseUidValidity :: Parser (Either ErrorMessage UntaggedResult)+parseUidValidity = parseOkResp $ parseNumber UIDValidity "UIDVALIDITY" ""++parseHighestModSeq :: Parser (Either ErrorMessage UntaggedResult)+parseHighestModSeq = parseOkResp $ parseNumber HighestModSeq "HIGHESTMODSEQ" ""++parseStatusItem :: Parser (Either ErrorMessage UntaggedResult)+parseStatusItem = do+  anyWord8+  itemName <- liftM decodeUtf8 $ AP.takeWhile1 isAtomChar+  string " "+  value <- liftM decodeUtf8 $ AP.takeWhile1 isDigit++  let decodingError = T.concat ["Error decoding '", value, "' as integer"]+  let valAsNumber = mapBoth (const decodingError) fst $ TR.decimal value++  return $ valAsNumber >>= \n -> case itemName of+    "MESSAGES" -> Right $ Messages n+    "RECENT" -> Right $ Recent n+    "UIDNEXT" -> Right $ UIDNext n+    "UIDVALIDITY" -> Right $ UIDValidity n+    "UNSEEN" -> Right $ Unseen n+    _ -> Left $ T.concat ["Unknown status item '", itemName, "'"]++parseStatus :: Parser (Either ErrorMessage UntaggedResult)+parseStatus = do+  string "STATUS "+  mailboxName <- liftM decodeUtf8 $ AP.takeWhile1 isAtomChar++  string " "+  statuses <- parseStatusItem `manyTill` string ")"+  let formattedStatuses = sequence statuses++  return $ liftM (StatusR mailboxName) formattedStatuses++parseCapabilityList :: Parser (Either ErrorMessage UntaggedResult)+parseCapabilityList = do+  string "CAPABILITY "+  caps <- (parseCapabilityWithValue <|> parseNamedCapability) `sepBy` word8 _space+  return . mapRight Capabilities $ sequence caps++parseCapabilityWithValue :: Parser (Either ErrorMessage Capability)+parseCapabilityWithValue = do+  name <- liftM decodeUtf8 (AP.takeWhile1 isAtomChar)+  word8 _equal+  value <- AP.takeWhile1 isAtomChar++  let decodedValue = decodeUtf8 value+  let decodingError = T.concat ["Error decoding '", decodedValue, "' as integer"]+  let valAsNumber = mapBoth (const decodingError) fst $ TR.decimal decodedValue+  case T.toLower name of+    "compress" -> return . Right . CCompress $ decodedValue+    "utf8" -> return . Right . CUtf8 $ decodedValue+    "auth" -> return . Right . CAuth $ decodedValue+    "appendlimit" -> return $ liftM CAppendLimit valAsNumber+    _ -> return . Right $ COther name (Just decodedValue)++parseNamedCapability :: Parser (Either ErrorMessage Capability)+parseNamedCapability = do+  name <- AP.takeWhile isAtomChar+  let decodedName = decodeUtf8 name++  return . Right $ case T.toLower decodedName of+    "imap4" -> CIMAP4+    "imap4rev1" -> CIMAP4+    "unselect" -> CUnselect+    "idle" -> CIdle+    "namespace" -> CNamespace+    "quota" -> CQuota+    "id" -> CId+    "children" -> CChildren+    "uidplus" -> CUIDPlus+    "enable" -> CEnable+    "move" -> CMove+    "condstore" -> CCondstore+    "esearch" -> CEsearch+    "list-extended" -> CListExtended+    "list-status" -> CListStatus+    _ -> if T.head decodedName == 'X'+          then CExperimental decodedName+          else COther decodedName Nothing++parseExpunge :: Parser (Either ErrorMessage UntaggedResult)+parseExpunge = do+  msgId <- AP.takeWhile1 isDigit+  string " EXPUNGE"++  return $ liftM Expunge (toInt msgId)++parseSearchResult :: Parser (Either ErrorMessage UntaggedResult)+parseSearchResult = do+  string "SEARCH "+  msgIds <- AP.takeWhile1 isDigit `sepBy` word8 _space+  let parsedIds = mapM toInt msgIds+  return $ liftM Search parsedIds

+ src/Network/IMAP/Parsers/Utils.hs view

@@ -0,0 +1,103 @@+module Network.IMAP.Parsers.Utils where++import Network.IMAP.Types++import Data.Attoparsec.ByteString+import qualified Data.Attoparsec.ByteString as AP+import Data.Word8+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8)+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString as BS+import Data.Either.Combinators (rightToMaybe)+import Control.Monad (liftM)++eatUntilClosingParen :: Parser BSC.ByteString+eatUntilClosingParen = scan 0 hadClosedAllParens <* word8 _parenright++hadClosedAllParens :: Int -> Word8 -> Maybe Int+hadClosedAllParens openingParenCount char+  | char == _parenright =+    if openingParenCount == 1+      then Nothing+      else Just $ openingParenCount - 1+  | char == _parenleft = Just $ openingParenCount + 1+  | otherwise =  Just openingParenCount+++parseEmailList :: Parser [EmailAddress]+parseEmailList = string "(" *> parseEmail `sepBy` word8 _space <* string ")"++parseEmail :: Parser EmailAddress+parseEmail = do+  string "(\""+  label <- nilOrValue $ AP.takeWhile1 (/= _quotedbl)+  string "\" NIL \""++  emailUsername <- AP.takeWhile1 (/= _quotedbl)+  string "\" \""+  emailDomain <- AP.takeWhile1 (/= _quotedbl)+  string "\")"+  let fullAddr = decodeUtf8 $ BSC.concat [emailUsername, "@", emailDomain]++  return $ EmailAddress (liftM decodeUtf8 label) fullAddr++nilOrValue :: Parser a -> Parser (Maybe a)+nilOrValue parser = rightToMaybe <$> AP.eitherP (string "NIL") parser++parseQuotedText :: Parser T.Text+parseQuotedText = do+  word8 _quotedbl+  date <- AP.takeWhile1 (/= _quotedbl)+  word8 _quotedbl++  return . decodeUtf8 $ date++parseNameAttribute :: Parser NameAttribute+parseNameAttribute = do+  string "\\"+  name <- AP.takeWhile1 isAtomChar+  return $ case name of+          "Noinferiors" -> Noinferiors+          "Noselect" -> Noselect+          "Marked" -> Marked+          "Unmarked" -> Unmarked+          "HasNoChildren" -> HasNoChildren+          _ -> OtherNameAttr $ decodeUtf8 name++parseListLikeResp :: BSC.ByteString -> Parser UntaggedResult+parseListLikeResp prefix = do+  string prefix+  string " ("+  nameAttributes <- parseNameAttribute `sepBy` word8 _space++  string ") \""+  delimiter <- liftM (decodeUtf8 . BS.singleton) AP.anyWord8+  string "\" "+  name <- liftM decodeUtf8 $ AP.takeWhile1 (/= _cr)++  let actualName = T.dropAround (== '"') name+  return $ ListR nameAttributes delimiter actualName++isAtomChar :: Word8 -> Bool+isAtomChar c = isLetter c || isNumber c || c == _hyphen || c == _quotedbl || c == _period++toInt :: BSC.ByteString -> Either ErrorMessage Int+toInt bs = if null parsed+    then Left errorMsg+    else Right . fst . head $ parsed+  where parsed = reads $ BSC.unpack bs+        errorMsg = T.concat ["Count not parse '", decodeUtf8 bs, "' as an integer"]++parseNumber :: (Int -> a) -> BSC.ByteString ->+  BSC.ByteString -> Parser (Either ErrorMessage a)+parseNumber constructor prefix postfix = do+  if not . BSC.null $ prefix+    then string prefix <* word8 _space+    else return BSC.empty+  number <- takeWhile1 isDigit+  if not . BSC.null $ postfix+    then word8 _space *> string postfix+    else return BSC.empty++  return $ liftM constructor (toInt number)