diff options
Diffstat (limited to 'Lazymail/Handlers.hs')
| -rw-r--r-- | Lazymail/Handlers.hs | 232 |
1 files changed, 232 insertions, 0 deletions
diff --git a/Lazymail/Handlers.hs b/Lazymail/Handlers.hs new file mode 100644 index 0000000..b0b1165 --- /dev/null +++ b/Lazymail/Handlers.hs @@ -0,0 +1,232 @@ +{- Event handlers for Lazymail + - + - Copyright 2013 Raúl Benencia <rul@kalgan.cc> + - + - Licensed under the GNU GPL version 3 or higher + -} + +module Lazymail.Handlers where + +import Codec.MIME.Parse(parseMIMEMessage) +import Codec.MIME.Type(MIMEValue(..)) +import Control.Exception(evaluate) +import Control.Monad.State +import Data.List(intercalate, stripPrefix, sort) +import System.FilePath(FilePath, takeFileName, dropTrailingPathSeparator) +import System.IO(openFile, IOMode(..), hClose) +import System.Locale(rfc822DateFormat) +import Data.DateTime(parseDateTime, startOfTime, formatDateTime) +import qualified System.IO.UTF8 as UTF8 + +import Lazymail.Email(lookupField, getBody, formatBody) +import Lazymail.Maildir +import Lazymail.Print +import Lazymail.State +import Lazymail.Types + +previousMode :: Mode -> LazymailCurses () +previousMode MaildirMode = (=<<) put $ get >>= \st -> return st { exitRequested = True } +previousMode EmailMode = do + st <- get + if (triggerUpdateIn . indexState $ st) + then do + changeMode MaildirMode + solveIndexUpdate + else put $ st { mode = IndexMode } +previousMode IndexMode = do + st <- get + let ist = (indexState st) { selectedRowIn = 0, scrollRowIn = 0 } + put $ st { mode = MaildirMode, indexState = ist } + +changeMode :: Mode -> LazymailCurses () +changeMode EmailMode = return () +changeMode IndexMode = do + st <- get + let fp = selectedEmailPath . indexState $ st + nfp <- if (isNew fp) + then liftIO $ markAsRead fp + else return fp + when (fp /= nfp) triggerIndexUpdate + st <- get + msg <- liftIO $ UTF8.readFile nfp + let email = parseMIMEMessage msg + let body = getBody $ email + let el = formatBody body $ screenColumns st + let est = (emailState st) { currentEmail = email, emailLines = el, scrollRowEm = 0 } + put $ st { mode = EmailMode, emailState = est } + +changeMode MaildirMode = do + st <- get + unsortedEmails <- liftIO $ do + freeOldHandlers st + let md = (selectedMD . maildirState) $ st + emails <- getMaildirEmails md + mapM toEmail emails + let selectedEmails' = reverse $ sort unsortedEmails + let scrollRow = scrollRowIn . indexState $ st + let scrRows = screenRows st + let indexState' = (indexState st) { + selectedEmails = selectedEmails' + , currentInLen = length selectedEmails' + , scrollBufferIn = formatIndexModeRows st $ scrollCrop scrollRow scrRows selectedEmails' + } + put $ st { mode = IndexMode, indexState = indexState' } + + where + toEmail fp = do + handle <- openFile fp ReadMode + msg <- UTF8.hGetContents handle + let value = parseMIMEMessage msg + let headers = mime_val_headers value + let date = maybe startOfTime id $ parseDateTime rfc822DateFormat $ takeWhile (/= '(') $ lookupField "date" headers + return (Email value date fp handle) + +freeOldHandlers st = mapM (hClose . emailHandle) $ selectedEmails . indexState $ st + +{- Boilerplate code -} +incSelectedRow IndexMode = do + st <- get + let inSt = indexState st + let selRow = selectedRowIn inSt + let topScrollRow = scrollRowIn inSt + let startScrolling = (div (screenRows st) 4) * 3 + let totalRows = currentInLen inSt + + if selRow > startScrolling && (topScrollRow <= (totalRows - (screenRows st))) + then do -- Scroll emails + let scrollRowIn' = scrollRowIn inSt + 1 + let scrollBufferIn' = formatIndexModeRows st $ scrollCrop scrollRowIn' (screenRows st) $ selectedEmails inSt + let inSt' = inSt { scrollRowIn = scrollRowIn', scrollBufferIn = scrollBufferIn' } + put st { indexState = inSt' } + else -- Move the selected row + put $ incrementSelectedRow st + +incSelectedRow MaildirMode = do + st <- get + let mdSt = maildirState st + let selRow = selectedRowMD mdSt + let topScrollRow = scrollRowMD mdSt + let startScrolling = (div (screenRows st) 4) * 3 + let totalRows = length $ detectedMDs mdSt + + if selRow > startScrolling && (topScrollRow <= (totalRows - (screenRows st))) + then do -- Scroll emails + let scrollRowMD' = topScrollRow + 1 + let scrollBufferMD' = scrollCrop scrollRowMD' (screenRows st) $ detectedMDs mdSt + let mdSt' = mdSt { scrollRowMD = scrollRowMD', scrollBufferMD = scrollBufferMD' } + put st { maildirState = mdSt' } + else -- Move the selected row + put $ incrementSelectedRow st + +{- Down-scrolling in Email mode -} +incSelectedRow EmailMode = do + st <- get + let est = emailState st + let cur = scrollRowEm est + let scrRows = screenRows st + let totalRows = length $ emailLines est + let est' = est { scrollRowEm = (cur + 1) } + + when ((totalRows - scrRows + (bodyStartRow est) - 1) > (scrollRowEm est)) $ + put $ st { emailState = est' } + +incSelectedRow _ = (=<<) put $ get >>= \st -> return $ incrementSelectedRow st + +{- More boilerplate code -} +decSelectedRow IndexMode = do + st <- get + let inSt = indexState st + let selRow = selectedRowIn inSt + let startScrolling = (div (screenRows st) 4) + let topScrollRow = scrollRowIn inSt + if topScrollRow > 0 && selRow < startScrolling + then do + let scrollRowIn' = scrollRowIn inSt - 1 + let scrollBufferIn' = formatIndexModeRows st $ scrollCrop scrollRowIn' (screenRows st) $ selectedEmails inSt + let inSt' = inSt { scrollRowIn = scrollRowIn', scrollBufferIn = scrollBufferIn' } + put st { indexState = inSt' } + else + put $ decrementSelectedRow st + +decSelectedRow MaildirMode = do + st <- get + let mdSt = maildirState st + let selRow = selectedRowMD mdSt + let startScrolling = (div (screenRows st) 4) + let topScrollRow = scrollRowMD mdSt + if topScrollRow > 0 && selRow < startScrolling + then do + let scrollRowMD' = scrollRowMD mdSt - 1 + let scrollBufferMD' = scrollCrop scrollRowMD' (screenRows st) $ detectedMDs mdSt + let mdSt' = mdSt { scrollRowMD = scrollRowMD', scrollBufferMD = scrollBufferMD' } + put st { maildirState = mdSt' } + else + put $ decrementSelectedRow st + +decSelectedRow EmailMode = do + st <- get + let est = emailState st + let cur = scrollRowEm est + let scrRows = screenRows st + let totalRows = length $ emailLines est + let est' = est { scrollRowEm = (cur - 1) } + + when (cur > 0) $ + put $ st { emailState = est' } + +decSelectedRow _ = (=<<) put $ get >>= \st -> return $ decrementSelectedRow st + +{- Given a list, it returns the elements that will be in the next screen refresh + - TODO: find a better name -} +scrollCrop top rows xs = take rows $ drop top xs + +formatIndexModeRows :: LazymailState -> [Email] -> [(FilePath, String)] +formatIndexModeRows st = map formatRow where + formatRow e = + let fp = emailPath e + email = emailValue e + hs = mime_val_headers email + str = normalizeLen (screenColumns st) $ intercalate ppSep $ + [ "[" ++ normalizeLen maxFlags (ppFlags . getFlags $ fp) ++ "]" + , formatDateTime "%b %d" $ emailDate e + , normalizeLen fromLen $ ppField $ lookupField "from" hs + , ppField $ lookupField "subject" hs + ] + in (fp, str) + +formatMaildirModeRows st = mapM formatRow where + formatRow fp = return $ (fp, (concat $ replicate (numPads - 1) pad) ++ name) where + bp = basePath st + str = case (stripPrefix bp fp) of + Nothing -> fp + Just s -> s + name' = takeFileName . dropTrailingPathSeparator $ str + name = takeFileName $ map (\x -> if x `elem` imapSep then '/' else x) name' + pad = " " + numPads = (length $ filter (== '/') str) + (length $ filter (`elem` imapSep) str) + imapSep = ['.'] -- IMAP usually separates its directories with dots + +triggerIndexUpdate :: LazymailCurses () +triggerIndexUpdate = do + st <- get + let ist = indexState st + put $ st { indexState = (ist { triggerUpdateIn = True }) } + +solveIndexUpdate :: LazymailCurses () +solveIndexUpdate = do + st <- get + let ist = indexState st + put $ st { indexState = (ist { triggerUpdateIn = False }) } + +triggerMaildirUpdate :: LazymailCurses () +triggerMaildirUpdate = do + st <- get + let mst = maildirState st + put $ st { maildirState = (mst { triggerUpdateMD = True }) } + +solveMaildirUpdate :: LazymailCurses () +solveMaildirUpdate = do + st <- get + let mst = maildirState st + put $ st { maildirState = (mst { triggerUpdateMD = False }) } + |