diff options
Diffstat (limited to 'Handlers.hs')
| -rw-r--r-- | Handlers.hs | 232 |
1 files changed, 0 insertions, 232 deletions
diff --git a/Handlers.hs b/Handlers.hs deleted file mode 100644 index 5c04f89..0000000 --- a/Handlers.hs +++ /dev/null @@ -1,232 +0,0 @@ -{- Event handlers for Lazymail - - - - Copyright 2013 Raúl Benencia <rul@kalgan.cc> - - - - Licensed under the GNU GPL version 3 or higher - -} - -module 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 Email(lookupField, getBody, formatBody) -import Maildir -import Print -import State -import 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 }) } - |