code.delx.au - offlineimap/blob - src/Network/IMAP/Parser.hs

   1 {- offlineimap component
   2 Copyright (C) 2008 John Goerzen <jgoerzen@complete.org>
   3
   4 This program is free software; you can redistribute it and/or modify
   5 it under the terms of the GNU General Public License as published by
   6 the Free Software Foundation; either version 2 of the License, or
   7 (at your option) any later version.
   8
   9 This program is distributed in the hope that it will be useful,
  10 but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 GNU General Public License for more details.
  13
  14 You should have received a copy of the GNU General Public License
  15 along with this program; if not, write to the Free Software
  16 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17 -}
  18
  19 module Network.IMAP.Parser where
  20 import Text.ParserCombinators.Parsec
  21 import Network.IMAP.Types
  22 import Text.Regex.Posix
  23 import Data.Int
  24 import Data.List
  25
  26 import Network.IMAP.Parser.Prim
  27
  28 {- | Read a full response from the server. -}
  29 readFullResponse :: Monad m =>
  30     IMAPConnection m ->         -- ^ The connection to the server
  31     m IMAPString
  32 readFullResponse conn =
  33     accumLines []
  34     where accumLines accum =
  35               do line <- getFullLine [] conn
  36                  if "* " `isPrefixOf` line
  37                     then accumLines (accum ++ line ++ "\r\n")
  38                     else return (accum ++ line ++ "\r\n")
  39
  40 {- | Read a full line from the server, handling any continuation stuff.
  41
  42 If a {x}\r\n occurs, then that string (including the \r\n) will occur
  43 literally in the result, followed by the literal read, and the rest of the
  44 data.
  45  -}
  46
  47 getFullLine :: Monad m =>
  48                IMAPString ->    -- ^ The accumulator (empty for first call)
  49                IMAPConnection m -> -- ^ IMAP connection
  50                m IMAPString        -- ^ Result
  51
  52 getFullLine accum conn =
  53     do input <- readLine conn
  54        case checkContinuation input of
  55          Nothing -> return (accum ++ input)
  56          Just (size) ->
  57              do literal <- readBytes conn size
  58                 getFullLine (accum ++ input ++ "\r\n" ++ literal) conn
  59     where checkContinuation :: String -> Maybe Int64
  60           checkContinuation i =
  61               case i =~ "\\{([0-9]+)\\}$" :: (String, String, String, [String]) of
  62                 (_, _, _, [x]) -> Just (read x)
  63                 _ -> Nothing
  64
  65 ----------------------------------------------------------------------
  66 -- Response parsing
  67 ----------------------------------------------------------------------
  68
  69 {- | Returns Left for a "BYE" response, or Right if we are ready to
  70 proceed with auth (or preauth). -}
  71 greeting :: IMAPParser (AuthReady, RespText)
  72 greeting =
  73     do string "* "
  74        respCondBye <|> respCondAuth
  75
  76 data AuthReady = AUTHOK | AUTHPREAUTH | AUTHBYE
  77           deriving (Eq, Read, Show)
  78
  79 data RespText = RespText {respTextCode :: Maybe String,
  80                            respTextMsg :: String}
  81                  deriving (Eq, Read, Show)
  82
  83 respCondAuth :: IMAPParser (AuthReady, RespText)
  84 respCondAuth =
  85     do s <- (string "OK" >> return AUTHOK) <|>
  86             (string "PREAUTH" >> return AUTHPREAUTH)
  87        sp
  88        t <- respText
  89        return (s, t)
  90
  91 respCondBye :: IMAPParser (AuthReady, RespText)
  92 respCondBye =
  93     do string "BYE "
  94        t <- respText
  95        return (AUTHBYE, t)
  96
  97 -- Less strict than mandated in RFC3501 formal syntax
  98 respText :: IMAPParser RespText
  99 respText =
 100     do code <- optionMaybe respTextCode
 101        t <- text
 102        return $ RespText code t
 103     where respTextCode =
 104               do char '['
 105                  a <- atom
 106                  b <- option "" (sp >> respTextCodeText)
 107                  char ']'
 108                  sp
 109                  case b of
 110                    [] -> return a
 111                    _ -> return $ a ++ " " ++ b
 112           respTextCodeText = many1 (noneOf (']' : crlf))
 113