----------------------------------------------------------------------
-- |
-- Module      :  Text.IMAPParsers
-- Copyright   :  (c) Jun Mukai 2006
-- License     :  BSD-style (see the file LICENSE)
-- 
-- Maintainer  :  mukai@jmuk.org
-- Stability   :  stable
-- Portability :  portable
-- 
-- Parsers for IMAP server responses
-- 

module Text.IMAPParsers where

import Text.Packrat.Parse hiding (space, spaces)
import Text.Packrat.Pos

import Data.Maybe
import Data.Word

import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS

type Mailbox = String
type UID = Word64
type Charset = String


data MailboxInfo = MboxInfo { _mailbox :: Mailbox
                            , _exists :: Integer
                            , _recent :: Integer
                            , _flags :: [Flag]
                            , _permanentFlags :: [Flag]
                            , _isWritable :: Bool
                            , _isFlagWritable :: Bool
                            , _uidNext :: UID
                            , _uidValidity :: UID
                            }
                 deriving (Show, Eq)


data Flag = Seen
          | Answered
          | Flagged
          | Deleted
          | Draft
          | Recent
          | Keyword String
            deriving Eq

instance Show Flag where
    showsPrec d f = showParen (d > app_prec) $ showString $ showFlag f
        where app_prec = 10
              showFlag Seen        = "\\Seen"
              showFlag Answered    = "\\Answered"
              showFlag Flagged     = "\\Flagged"
              showFlag Deleted     = "\\Deleted"
              showFlag Draft       = "\\Draft"
              showFlag Recent      = "\\Recent"
              showFlag (Keyword s) = "\\" ++ s

data Attribute = Noinferiors
               | Noselect
               | Marked
               | Unmarked
               | OtherAttr String
                 deriving (Show, Eq)

data MboxUpdate = MboxUpdate { exists :: Maybe Integer
                             , recent :: Maybe Integer }
                deriving (Show, Eq)

data StatusCode = ALERT
                | BADCHARSET [Charset]
                | CAPABILITY_sc [String]
                | PARSE
                | PERMANENTFLAGS [Flag]
                | READ_ONLY
                | READ_WRITE
                | TRYCREATE
                | UIDNEXT_sc UID
                | UIDVALIDITY_sc UID
                | UNSEEN_sc Integer
                  deriving (Eq, Show)

data ServerResponse = OK (Maybe StatusCode) String
                    | NO (Maybe StatusCode) String
                    | BAD (Maybe StatusCode) String
                    | PREAUTH (Maybe StatusCode) String
                      deriving (Eq, Show)


-- | the query data type for the status command
data MailboxStatus = MESSAGES     -- ^ the number of messages in the mailbox
                   | RECENT       -- ^ the number of messages with the \Recent flag set
                   | UIDNEXT      -- ^ the next unique identifier value of the mailbox
                   | UIDVALIDITY  -- ^ the unique identifier validity value of the mailbox
                     deriving (Show, Read, Eq)




data RespDerivs =
    RespDerivs { dvFlags  :: Result RespDerivs [Flag]
               , advTag   :: Result RespDerivs String
               , advChar  :: Result RespDerivs Char
               , advPos   :: Pos
               }

instance Derivs RespDerivs where
    dvChar = advChar
    dvPos  = advPos


eval :: (RespDerivs -> Result RespDerivs r) -> String -> ByteString -> r
eval pMain tag s = case pMain (parse tag (Pos tag 1 1) s) of
                     Parsed v d' e' -> v
                     NoParse e      -> error (show e)


parse :: String -> Pos -> ByteString -> RespDerivs
parse tagstr pos s = d
    where d    = RespDerivs flag tag chr pos
          flag = pParenFlags d
          tag  = Parsed tagstr d (nullError d)
          chr  = if BS.null s
                 then NoParse (eofError d)
                 else let (c, s') = (BS.head s, BS.tail s)
                      in Parsed c (parse tagstr (nextPos pos c) s')
                           (nullError d)

eval' :: (RespDerivs -> Result RespDerivs r) -> String -> String -> r
eval' pMain tag s = case pMain (parse' tag (Pos tag 1 1) s) of
                      Parsed v d' e' -> v
                      NoParse e      -> error (show e)

parse' :: String -> Pos -> String -> RespDerivs
parse' tagstr pos s = d
    where d    = RespDerivs flag tag chr pos
          flag = pParenFlags d
          tag  = Parsed tagstr d (nullError d)
          chr  = case s of
                   (c:s') -> Parsed c (parse' tagstr (nextPos pos c) s')
                               (nullError d)
                   _      -> NoParse (eofError d)

mkMboxUpdate untagged = (MboxUpdate exists recent, others)
    where exists = lookup "EXISTS" $ catLefts untagged
          recent = lookup "RECENT" $ catLefts untagged
          others = catRights untagged

pNone :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, ())
Parser pNone =
    do untagged <- many pOtherLine
       resp <- Parser pDone
       let (mboxUp, _) = mkMboxUpdate untagged
       return (resp, mboxUp, ())

pCapability :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [String])
Parser pCapability =
    do untagged <- many (pCapabilityLine <|> pOtherLine)
       resp <- Parser pDone
       let (mboxUp, caps) = mkMboxUpdate untagged
       return (resp, mboxUp, concat caps)
           

pList :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [([Attribute], String, Mailbox)])
Parser pList =
    do untagged <- many (pListLine "LIST" <|> pOtherLine)
       resp <- Parser pDone
       let (mboxUp, listRes) = mkMboxUpdate untagged
       return (resp, mboxUp, listRes)

pLsub :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [([Attribute], String, Mailbox)])
Parser pLsub =
    do untagged <- many (pListLine "LSUB" <|> pOtherLine)
       resp <- Parser pDone
       let (mboxUp, listRes) = mkMboxUpdate untagged
       return (resp, mboxUp, listRes)

pStatus :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [(MailboxStatus, Integer)])
Parser pStatus =
    do untagged <- many (pStatusLine <|> pOtherLine)
       resp <- Parser pDone
       let (mboxUp, statRes) = mkMboxUpdate untagged
       return (resp, mboxUp, concat statRes)

pExpunge :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [Integer])
Parser pExpunge =
    do untagged <- many ((do string "* "
                             n <- pExpungeLine
                             return $ Right ("EXPUNGE", n))
                         <|> pOtherLine)
       resp <- Parser pDone
       let (mboxUp, expunges) = mkMboxUpdate untagged
       return (resp, mboxUp, lookups "EXPUNGE" expunges)

pSearch :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [UID])
Parser pSearch =
    do untagged <- many (pSearchLine <|> pOtherLine)
       resp <- Parser pDone
       let (mboxUp, searchRes) = mkMboxUpdate untagged 
       return (resp, mboxUp, concat searchRes)


pSelect :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, MailboxInfo)
Parser pSelect =
    do untagged <- many (pSelectLine
                         <|> (do string "* "
                                 anyChar `manyTill` crlfP
                                 return id))
       resp <- Parser pDone
       let box = case resp of
                   OK writable _ ->
                       emptyBox { _isWritable = isJust writable && fromJust writable == READ_WRITE }
                   _ -> emptyBox
       return (resp, MboxUpdate Nothing Nothing, foldl (flip ($)) box untagged)
    where emptyBox = MboxInfo "" 0 0 [] [] False False 0 0

pFetch :: RespDerivs -> Result RespDerivs (ServerResponse, MboxUpdate, [(Integer, [(String, String)])])
Parser pFetch =
    do untagged <- many (pFetchLine <|> pOtherLine)
       resp <- Parser pDone
       let (mboxUp, fetchRes) = mkMboxUpdate untagged
       return (resp, mboxUp, fetchRes)


pDone :: RespDerivs -> Result RespDerivs ServerResponse
Parser pDone = do tag <- Parser advTag
                  string tag >> space
                  respCode <- parseCode
                  space
                  stat <- optional (do s <- parseStatusCode
                                       space >> return s)
                  body <- anyChar `manyTill` crlfP
                  return $ respCode stat body
    where parseCode = choice $ [ string "OK" >> return OK
                               , string "NO" >> return NO
                               , string "BAD" >> return BAD
                               , string "PREAUTH" >> return PREAUTH
                               ]
          parseStatusCode =
              between (char '[') (char ']') $
              choice [ string "ALERT" >> return ALERT
                     , do { string "BADCHARSET"
                          ; ws <- optional parenWords
                          ; return $ BADCHARSET $ fromMaybe [] ws }
                     , do { string "CAPABILITY"
                          ; space
                          ; ws <- (many1 $ noneOf " ]") `sepBy1` space
                          ; return $ CAPABILITY_sc ws }
                     , string "PARSE" >> return PARSE
                     , do { string "PERMANENTFLAGS" >> space >> char '('
                          ; fs <- pFlag `sepBy1` spaces1
                          ; char ')'
                          ; return $ PERMANENTFLAGS fs }
                     , string "READ-ONLY" >> return READ_ONLY
                     , string "READ-WRITE" >> return READ_WRITE 
                     , string "TRYCREATE" >> return TRYCREATE
                     , do { string "UNSEEN" >> space
                          ; num <- many1 digit
                          ; return $ UNSEEN_sc $ read num }
                     , do { string "UIDNEXT" >> space
                          ; num <- many1 digit
                          ; return $ UIDNEXT_sc $ read num }
                     , do { string "UIDVALIDITY" >> space
                          ; num <- many1 digit
                          ; return $ UIDVALIDITY_sc $ read num }
                     ]
          parenWords = between (space >> char '(') (char ')')
                         (many1 (noneOf " )") `sepBy1` space)



pFlag :: Parser RespDerivs Flag
pFlag = do char '\\'
           choice [ string "Seen"     >> return Seen
                  , string "Answered" >> return Answered
                  , string "Flagged"  >> return Flagged
                  , string "Deleted"  >> return Deleted
                  , string "Draft"    >> return Draft
                  , string "Recent"   >> return Recent
                  , char '*'          >> return (Keyword "*")
                  , many1 atomChar    >>= return . Keyword ]
    <|> (many1 atomChar >>= return . Keyword)

pParenFlags :: RespDerivs -> Result RespDerivs [Flag]
Parser pParenFlags = do char '('
                        fs <- pFlag `sepBy` space
                        char ')'
                        return fs

atomChar :: Derivs d => Parser d Char
atomChar = noneOf " (){%*\"\\]"


pNumberedLine :: String -> Parser RespDerivs Integer
pNumberedLine str = do num <- many1 digit
                       space
                       string str
                       crlfP
                       return $ read num

pExistsLine, pRecentLine, pExpungeLine :: Parser RespDerivs Integer
pExistsLine  = pNumberedLine "EXISTS"
pRecentLine  = pNumberedLine "RECENT"
pExpungeLine = pNumberedLine "EXPUNGE"


pOtherLine :: Parser RespDerivs (Either (String, Integer) b)
pOtherLine = do string "* "
                choice [ pExistsLine >>= \n -> return (Left ("EXISTS", n))
                       , pRecentLine >>= \n -> return (Left ("RECENT", n))
                       , blankLine >> return (Left ("", 0))]
    where blankLine = anyChar `manyTill` crlfP


pCapabilityLine :: Parser RespDerivs (Either a [String])
pCapabilityLine = do string "* CAPABILITY "
                     ws <- many1 (noneOf " \r") `sepBy` space
                     crlfP
                     return $ Right ws


pListLine :: String
          -> Parser RespDerivs (Either a ([Attribute], String, Mailbox))
pListLine list = 
    do string "* " >> string list >> space
       attrs <- parseAttrs
       sep <- parseSep
       mbox <- parseMailbox
       return $ Right (attrs, sep, mbox)
    where parseAttr =
              do char '\\'
                 choice [ string "Noinferior" >> return Noinferiors
                        , string "Noselect" >> return Noselect
                        , string "Marked" >> return Marked
                        , string "Unmarked" >> return Unmarked
                        , many atomChar >>= return . OtherAttr
                        ]
          parseAttrs = do char '('
                          attrs <- parseAttr `sepBy` space
                          char ')'
                          return attrs
          parseSep = space >> char '"' >> anyChar `manyTill` char '"'
          parseMailbox = space >> anyChar `manyTill` crlfP


pStatusLine :: Parser RespDerivs (Either a [(MailboxStatus, Integer)])
pStatusLine =
    do string "* STATUS "
       mbox <- anyChar `manyTill` space
       stats <- between (char '(') (char ')') (parseStat `sepBy1` space)
       crlfP
       return $ Right stats
    where parseStat =
              do cons <- choice [ string "MESSAGES"    >>= return . read
                                , string "RECENT"      >>= return . read
                                , string "UIDNEXT"     >>= return . read
                                , string "UIDVALIDITY" >>= return . read
                                ]
                 space
                 num <- many1 digit >>= return . read
                 return (cons, num)


pSearchLine :: Parser RespDerivs (Either a [UID])
pSearchLine = do string "* SEARCH "
                 nums <- (many1 digit) `sepBy` space
                 crlfP
                 return $ Right $ map read nums


pSelectLine :: Parser RespDerivs (MailboxInfo -> MailboxInfo)
pSelectLine =
    do string "* "
       choice [ pExistsLine >>= \n -> return (\mbox -> mbox { _exists = n })
              , pRecentLine >>= \n -> return (\mbox -> mbox { _recent = n })
              , pFlags  >>= \fs -> return (\mbox -> mbox { _flags = fs })
              , string "OK " >> okResps ]
    where pFlags = do string "FLAGS "
                      char '('
                      fs <- pFlag `sepBy` space
                      char ')' >> crlfP
                      return fs
          okResps =
              do char '['
                 v <- choice [ do { string "UNSEEN "
                                  ; n <- many1 digit
                                  ; return $ id }
                             , do { string "PERMANENTFLAGS ("
                                  ; fs <- pFlag `sepBy` space
                                  ; char ')'
                                  ; return $ \mbox ->
                                      mbox { _isFlagWritable = 
                                               Keyword "*" `elem` fs
                                           , _permanentFlags =
                                               filter (/= Keyword "*") fs } }
                             , do { string "UIDNEXT "
                                  ; n <- many1 digit
                                  ; return $ \mbox ->
                                      mbox { _uidNext = read n } }
                             , do { string "UIDVALIDITY "
                                  ; n <- many1 digit
                                  ; return $ \mbox ->
                                      mbox { _uidValidity = read n } }
                             ]
                 char ']'
                 anyChar `manyTill` crlfP
                 return v


pFetchLine :: Parser RespDerivs (Either a (Integer, [(String, String)]))
pFetchLine =
    do string "* "
       num <- many1 digit
       string " FETCH" >> spaces
       char '('
       pairs <- pPair `sepBy` space
       char ')'
       crlfP
       return $ Right $ (read num, pairs)
    where pPair = do key <- anyChar `manyTill` space
                     value <- (do char '('
                                  v <- pParen `sepBy` space
                                  char ')'
                                  return ("("++unwords v++")"))
                          <|> (do char '{'
                                  num <- many1 digit >>= return . read
                                  char '}' >> crlfP
                                  sequence $ replicate num anyChar)
                          <|> (do char '"'
                                  v <- noneOf "\"" `manyTill` char '"'
                                  return ("\""++v++"\""))
                          <|> many1 atomChar
                     return (key, value)
          pParen = (do char '"'
                       v <- noneOf "\"" `manyTill` char '"'
                       return ("\""++v++"\""))
               <|> (do char '('
                       v <- pParen `sepBy` space
                       char ')'
                       return ("("++unwords v++")"))
               <|> (do char '\\'
                       v <- many1 atomChar
                       return ('\\':v))
               <|> many1 atomChar




----------------------------------------------------------------------
-- auxiliary parsers
space   = char ' '
spaces  = many space
spaces1 = many1 space

crlf :: String
crlf = "\r\n"

crlfP :: Derivs d => Parser d String
crlfP = string crlf

lookups :: Eq a => a -> [(a, b)] -> [b]
lookups _ [] = []
lookups k ((k', v):tl) | k == k'   = v : lookups k tl
                       | otherwise = lookups k tl

---- Either handling
catRights :: [Either a b] -> [b]
catRights []           = []
catRights (Right r:tl) = r : catRights tl
catRights (_:tl)       = catRights tl

catLefts :: [Either a b] -> [a]
catLefts []           = []
catLefts (Left r:tl) = r : catLefts tl
catLefts (_:tl)       = catLefts tl

isLeft, isRight :: Either a b -> Bool
isLeft (Left _) = True
isLeft _        = False
isRight (Right _) = True
isRight _         = False

getLeft :: Either a b -> a
getLeft (Left l) = l
getLeft _        = error "not left"
getRight :: Either a b -> b
getRight (Right r) = r
getRight _         = error "not right"