diff options
Diffstat (limited to 'src/Lazymail')
| -rw-r--r-- | src/Lazymail/Config.hs | 55 | ||||
| -rw-r--r-- | src/Lazymail/Email.hs | 132 | ||||
| -rw-r--r-- | src/Lazymail/Handlers.hs | 232 | ||||
| -rw-r--r-- | src/Lazymail/Keymap.hs | 16 | ||||
| -rw-r--r-- | src/Lazymail/Maildir.hs | 142 | ||||
| -rw-r--r-- | src/Lazymail/Print.hs | 80 | ||||
| -rw-r--r-- | src/Lazymail/Screen.hs | 268 | ||||
| -rw-r--r-- | src/Lazymail/State.hs | 126 | ||||
| -rw-r--r-- | src/Lazymail/Types.hs | 128 |
9 files changed, 1179 insertions, 0 deletions
diff --git a/src/Lazymail/Config.hs b/src/Lazymail/Config.hs new file mode 100644 index 0000000..2566bc9 --- /dev/null +++ b/src/Lazymail/Config.hs @@ -0,0 +1,55 @@ +{- Lazymail user configuration + - + - Copyright 2013 Raúl Benencia <rul@kalgan.cc> + - + - Licensed under the GNU GPL version 3 or higher + - + -} + +module Lazymail.Config(LazymailConfig(..), defaultConfig, customConfig) where + +import Data.List(sort, stripPrefix) +import System.Posix.Files(getSymbolicLinkStatus, isSymbolicLink) +import UI.NCurses(Color(..)) + +import Lazymail.Keymap +import Lazymail.Types(LazymailConfig(..)) + +defaultConfig = LazymailConfig { + baseColor = (ColorWhite, ColorBlack) + , selectionColor = (ColorBlack, ColorWhite) + , statusBarColor = (ColorBlack, ColorBlue) + , headerColor = (ColorGreen, ColorBlack) + , newEmailColor = (ColorBlue, ColorBlack) + , showStatusBar = True + , initialPath = "" + , filterMaildirsHook = \mds -> return mds + , indexDateFormat = "%m %d" + , headersToShow = ["date", "from", "to", "cc", "bcc", "subject", "reply-to"] + , globalKeymaps = defaultGlobalKeymap + , maildirModeKeymap = defaultMaildirKeymap + , indexModeKeymap = defaultIndexKeymap + , emailModeKeymap = defaultEmailKeymap + , composeModeKeymap = defaultComposeKeymap +} + +-- +-- | Users should modify customConfig in order to set-up their +-- preferences. In a possible future maybe I'll work in a not-so-crappy +-- config system. +-- +--customConfig = defaultConfig { initialPath = "/home/rul/mail/"} + +customConfig = defaultConfig { initialPath = "/home/rul/mail/" + , filterMaildirsHook = filterSymlinks } + +filterSymlinks :: [FilePath] -> IO [FilePath] +filterSymlinks [] = return [] +filterSymlinks (md:mds) = do + filtered <- do + fs <- getSymbolicLinkStatus md + rest <- filterSymlinks mds + if isSymbolicLink fs + then return rest + else return (md:rest) + return $ sort filtered
\ No newline at end of file diff --git a/src/Lazymail/Email.hs b/src/Lazymail/Email.hs new file mode 100644 index 0000000..fc63a89 --- /dev/null +++ b/src/Lazymail/Email.hs @@ -0,0 +1,132 @@ +{- Email accessors. + - + - Copyright 2013 Raúl Benencia <rul@kalgan.cc> + - + - Licensed under the GNU GPL version 3 or higher + - + -} +module Lazymail.Email where + +import Codec.MIME.Type(MIMEValue(..), MIMEContent(..), showMIMEType, Type(..), MIMEType(..)) +import Data.Char(toLower) +import Data.List(find) + +getBody :: MIMEValue -> String +getBody msg = + case mime_val_content msg of + Single c -> c + Multi mvs -> case firstTextPart mvs of + Just mv -> unwrapContent . mime_val_content $ mv + Nothing -> "This email has no displayable content." + where + unwrapContent (Single c) = c + +-- hackish function for showing the email. In he future the logic of this +-- function should be improved. +firstTextPart [] = Nothing +firstTextPart (mv:mvs) = case mime_val_content mv of + Single c -> if isText mv then Just mv else firstTextPart mvs + Multi mvs' -> firstTextPart mvs' + + where + isText = \mv -> case (mimeType $ mime_val_type mv) of + Text text -> True + _ -> False + +getHeaders :: MIMEValue -> [(String,String)] +getHeaders = mime_val_headers + +-- | Convert a String to multiple Strings, cropped by the maximum column +-- size if necessary. +formatBody :: String -> Int -> [String] +formatBody body maxColumns = format [] [] body where + format parsed acc [] = parsed ++ [acc] + format parsed acc ('\r':'\n':xs) = format (parsed ++ [acc]) [] xs + format parsed acc rest@(x:xs) | length acc < maxColumns = format parsed (acc ++ [x]) xs + | otherwise = format (parsed ++ [acc]) "+" rest + + +-- The following function is a verbatim copy of the unexported function in +-- Codec.MIME.Parse. +-- case in-sensitive lookup of field names or attributes\/parameters. +lookupField' :: String -> [(String,a)] -> Maybe a +lookupField' n ns = + -- assume that inputs have been mostly normalized already + -- (i.e., lower-cased), but should the lookup fail fall back + -- to a second try where we do normalize before giving up. + case lookup n ns of + x@Just{} -> x + Nothing -> + let nl = map toLower n in + case find (\ (y,_) -> nl == map toLower y) ns of + Nothing -> Nothing + Just (_,x) -> Just x + +unwrapField = maybe "" id + +lookupField n ns = unwrapField $ lookupField' n ns + + + + + + + + + + + + + + + + + + + + + + + +{-import Text.Parsec.Error(ParseError) +import Text.ParserCombinators.Parsec (parse) +import Text.ParserCombinators.Parsec.Rfc2822 + +parseEmail :: String -> Message +parseEmail msg = unwrapEmail $ parse message "<stdin>" $ fixEol msg + +unwrapEmail (Right email) = email +getFields (Message fs _) = fs + +-- There is obviously a pattern here. Find a way to narrow it down. +getReturnPath fs = do { ReturnPath f <- fs; f } +getFrom fs = do { From f <- fs; f } +getTo fs = do { To f <- fs; f } +getCc fs = do { Cc f <- fs; f } +getBcc fs = do { Bcc f <- fs; f } +getReplyTo fs = do { ReplyTo f <- fs; f } +getSubject fs = do { Subject f <- fs; f } +getMessageID fs = do { MessageID f <- fs; f } +getInReplyTo fs = do { InReplyTo f <- fs; f } +getReferences fs = do { References f <- fs; f } +getComments fs = do { Comments f <- fs; f } +getKeywords fs = do { Keywords f <- fs; f } +--getDate fs = do { Date f <- fs; f } +--getResentDate fs = do { ResentDate f <- fs; f } +getResentFrom fs = do { ResentFrom f <- fs; f } +--getResentSender fs = do { ResentSender f <- fs; f } +getResentTo fs = do { ResentTo f <- fs; f } +getResentCc fs = do { ResentCc f <- fs; f } +getResentBcc fs = do { ResentBcc f <- fs; f } +getResentMessageID fs = do { ResentMessageID f <- fs; f } +--getReceived fs = do { Received f <- fs; f } + +getBody (Message _ []) = "Empty body" +getBody (Message _ body) = body + +-- Make sure all lines are terminated by CRLF. +fixEol :: String -> String +fixEol ('\r':'\n':xs) = '\r' : '\n' : fixEol xs +fixEol ('\n':xs) = '\r' : '\n' : fixEol xs +fixEol (x:xs) = x : fixEol xs +fixEol [] = []-} diff --git a/src/Lazymail/Handlers.hs b/src/Lazymail/Handlers.hs new file mode 100644 index 0000000..b0b1165 --- /dev/null +++ b/src/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 }) } + diff --git a/src/Lazymail/Keymap.hs b/src/Lazymail/Keymap.hs new file mode 100644 index 0000000..1cef1b1 --- /dev/null +++ b/src/Lazymail/Keymap.hs @@ -0,0 +1,16 @@ +module Lazymail.Keymap + ( defaultGlobalKeymap + , defaultMaildirKeymap + , defaultIndexKeymap + , defaultEmailKeymap + , defaultComposeKeymap + ) where + +import UI.NCurses(Event(..)) +import Lazymail.Types(LazymailCurses) + +defaultGlobalKeymap = [] +defaultMaildirKeymap = [] +defaultIndexKeymap = [] +defaultEmailKeymap = [] +defaultComposeKeymap = []
\ No newline at end of file diff --git a/src/Lazymail/Maildir.hs b/src/Lazymail/Maildir.hs new file mode 100644 index 0000000..1793105 --- /dev/null +++ b/src/Lazymail/Maildir.hs @@ -0,0 +1,142 @@ +{- Utilities for working with Maildir format. + - + - Copyright 2013 Raúl Benencia <rul@kalgan.cc> + - + - Licensed under the GNU GPL version 3 or higher + - + -} + +module Lazymail.Maildir where + +import Control.Monad.Loops(allM) +import Control.Monad (forM, filterM) +import Data.List(isPrefixOf) +import System.Directory (doesDirectoryExist, getDirectoryContents, renameFile) +import System.FilePath ((</>), takeFileName, takeDirectory, splitDirectories, joinPath) +import System.IO(IOMode(..), hGetContents, openFile) + +import Lazymail.Types(Maildir, Flag(..), Flags) + +isMaildir :: FilePath -> IO Bool +isMaildir fp = allM doesDirectoryExist [ fp + , fp </> "cur" + , fp </> "new" + , fp </> "tmp"] + +getMaildirEmails md = do + r <- (getReadEmails md) + n <- (getNewEmails md) + return $ r ++ n + +getReadEmails md = getEmails $ md </> "cur" +getNewEmails md = getEmails $ md </> "new" + +getEmails fp = do + contents <- getDirectoryContents fp + return $ map (fp </>) $ filter (`notElem` [".", ".."]) contents + +{- | Returns information about specific messages. -} +getMessages :: Maildir -> [FilePath] -> IO [(FilePath, Flags, String)] +getMessages mb list = do + messages <- getAll mb + return $ filter (\(id, f, m) -> id `elem` list) messages + +{- Given a mail in a Maildir, mark it as read -} +markAsRead :: FilePath -> IO FilePath +markAsRead fp = + case newPath of + Nothing -> return fp + Just path -> do + renameFile fp path + return path + where newPath = + if not $ isNew fp + then Just fp + else do + let fil = takeFileName fp + let dir = takeDirectory fp + let spl = splitDirectories dir + case last spl of + "cur" -> Just $ fp ++ "S" + "new" -> Just $ (joinPath . init $ spl) </> ("cur" </> (fil ++ "S")) + _ -> Nothing + + +-- Based on getRecursiveContents from Real World Haskell +getMaildirsRecursively :: FilePath -> IO [Maildir] +getMaildirsRecursively topdir = do + result <- search topdir + includeTopDir <- isMaildir topdir + if includeTopDir + then return (topdir:result) + else return result + + where + search topdir = do + names <- getDirectoryContents topdir + let properNames = filter (`notElem` [".", ".."]) names + paths <- forM properNames $ \name -> do + let path = topdir </> name + isDirectory <- doesDirectoryExist path + if isDirectory + then do + result <- search path + return ([path] ++ result) + else return [] + + filterM isMaildir (concat paths) + + +{- The following code is an implementation of the Mailbox interface -} +listIDs :: Maildir -> IO [FilePath] +listIDs md = getNewIDs md `appendM` getReadIDs md + where mxs `appendM` mxs' = do + xs <- mxs + xs' <- mxs' + return (xs ++ xs') + +getNewIDs :: Maildir -> IO [FilePath] +getNewIDs md = getIDs (md </> "new") + +getReadIDs :: Maildir -> IO [FilePath] +getReadIDs md = getIDs (md </> "cur") + +getIDs :: FilePath -> IO [FilePath] +getIDs fp = do + names <-getDirectoryContents fp + let properNames = filter (`notElem` [".", ".."]) names + return $ map (fp </>) properNames + +listMessageFlags :: Maildir -> IO [(FilePath, Flags)] +listMessageFlags fp = do + ids <- (listIDs fp) + let flags = map getFlags ids + return (zip ids flags) + +getFlags :: FilePath -> Flags +getFlags fp = addNew $ map toFlag $ strip fp + where strip x + | null x = [] + | ":2," `isPrefixOf` x = drop 3 x + | otherwise = let (discard, analyze) = span (/= ':') fp + in strip analyze + addNew flags = if elem SEEN flags then flags else (NEW:flags) + +isNew :: FilePath -> Bool +isNew fp = elem NEW $ getFlags fp + +toFlag :: Char -> Flag +toFlag c | c == 'S' = SEEN + | c == 'A' = ANSWERED + | c == 'F' = FLAGGED + | c == 'D' = DRAFT + | c == 'P' = FORWARDED + | c == 'T' = DELETED + | otherwise = OTHERFLAG [c] + +getAll :: Maildir -> IO [(FilePath, Flags, String)] +getAll fp = do + ids <- listIDs fp + msgs <- mapM (\x -> hGetContents =<< openFile x ReadMode) ids + let flags = map getFlags ids + return $ zip3 ids flags msgs diff --git a/src/Lazymail/Print.hs b/src/Lazymail/Print.hs new file mode 100644 index 0000000..15e9df1 --- /dev/null +++ b/src/Lazymail/Print.hs @@ -0,0 +1,80 @@ +{- Printing utilities. + - + - Copyright 2013 Raúl Benencia <rul@kalgan.cc> + - + - Licensed under the GNU GPL version 3 or higher + - + -} + +module Lazymail.Print where + +import Data.Char (isSpace) +import Data.List (intercalate) + +import Lazymail.Email +import Codec.Text.Rfc1342 +import Lazymail.Types(Flag(..), Flags) + +unquote xs= if (head xs == '"' && last xs == '"') then (tail . init) xs else xs + +ppField = flat . decodeField + +{- Pretty print a RFC822 date format -} + + +fromLen :: Int +fromLen = 20 + +maxFlags :: Int +maxFlags = 4 + +flat xs = intercalate " " $ map (dropWhile isSpace) $ map (filter (/= '\r')) $ lines xs + +ppFlags :: Flags -> String +ppFlags = map ppFlag + +ppFlag :: Flag -> Char +ppFlag NEW = 'N' +ppFlag SEEN = 'S' +ppFlag ANSWERED = 'A' +ppFlag FLAGGED = 'F' +ppFlag DRAFT = 'D' +ppFlag FORWARDED = 'P' +ppFlag DELETED = 'T' +ppFlag (OTHERFLAG [c]) = c + +ppSep = " " + +normalizeLen len cs = if (length cs > len) + then shorten len cs + else if (length cs < len) + then fillWithSpace len cs + else cs + +fillWithSpace len cs = cs ++ (take (len - length cs) . repeat $ ' ') + +-- The following functions are from DynamicLog xmonad-contrib source + +-- | Wrap a string in delimiters, unless it is empty. +wrap :: String -- ^ left delimiter + -> String -- ^ right delimiter + -> String -- ^ output string + -> String +wrap _ _ "" = "" +wrap l r m = l ++ m ++ r + +-- | Pad a string with a leading and trailing space. +pad :: String -> String +pad = wrap " " " " + +-- | Trim leading and trailing whitespace from a string. +trim :: String -> String +trim = f . f + where f = reverse . dropWhile isSpace + +-- | Limit a string to a certain length, adding "..." if truncated. +shorten :: Int -> String -> String +shorten n xs | length xs < n = xs + | otherwise = take (n - length end) xs ++ end + where + end = "..." diff --git a/src/Lazymail/Screen.hs b/src/Lazymail/Screen.hs new file mode 100644 index 0000000..699f84e --- /dev/null +++ b/src/Lazymail/Screen.hs @@ -0,0 +1,268 @@ +{- Lazymail interaction with curses. + - + - Copyright 2013 Raúl Benencia <rul@kalgan.cc> + - + - Licensed under the GNU GPL version 3 or higher + - + - This code is in an urgent need of a big refactoring. + -} + +module Lazymail.Screen where + +import Codec.MIME.Type(MIMEValue(..)) +import Control.Monad.Trans(liftIO) +import Control.Monad.Reader +import Control.Monad.State +import Data.Char(toUpper) +import Data.List(isPrefixOf) +import System.Exit +import UI.NCurses + +-- Local imports +import Lazymail.Config +import qualified Lazymail.Handlers as EH +import Lazymail.Maildir +import Lazymail.Email(lookupField, getBody, getHeaders, lookupField') +import Lazymail.Print +import Codec.Text.Rfc1342 +import Lazymail.State +import Lazymail.Types + +{- This function is the nexus between Curses and IO -} +entryPoint :: Lazymail () +entryPoint = do + st <- get + cfg <- ask + maildirs <- liftIO $ do + mds <- getMaildirsRecursively $ basePath st + (filterMaildirsHook cfg) mds + formattedMDs <- EH.formatMaildirModeRows st maildirs + let mdState = (maildirState st) { detectedMDs = formattedMDs } + liftIO $ runCurses $ runStateT (runReaderT startCurses cfg) (st { maildirState = mdState }) + return () + +{- Initial point of screen related functions. Get the number of rows, + - colors, and start drawing the modes -} +startCurses :: LazymailCurses () +startCurses = do + st <- get + cfg <- ask + (=<<) put $ liftCurses $ do + setEcho False + setCursorMode CursorInvisible + w <- defaultWindow + (rows, cols) <- screenSize + basColID <- newColorID (fst . baseColor $ cfg) (snd . baseColor $ cfg) 1 + selColID <- newColorID (fst . selectionColor $ cfg) (snd . selectionColor $ cfg) 2 + staColID <- newColorID (fst . statusBarColor $ cfg) (snd . statusBarColor $ cfg) 3 + heaColID <- newColorID (fst . headerColor $ cfg) (snd . headerColor $ cfg) 4 + newColID <- newColorID (fst . newEmailColor $ cfg) (snd . newEmailColor $ cfg) 5 + let style = ColorStyle basColID selColID staColID heaColID newColID + return $ st { screenRows = fromIntegral $ rows - 1 + , screenColumns = fromIntegral $ cols + , colorStyle = style } + resetScrollBuffer + screenLoop + +{- This function will loop til the user decides to leave -} +screenLoop :: LazymailCurses () +screenLoop = do + w <- liftCurses $ defaultWindow + cfg <- ask + get >>= \st -> + (liftCurses . (updateWindow w) $ runStateT (runReaderT performUpdate cfg) st) >>= put . snd + liftCurses $ render + handleEvent + get >>= \st -> if (not . exitRequested) st + then screenLoop + else return () + +{- Perform the screen update, by cleaning it first. -} +performUpdate :: LazymailUpdate LazymailState +performUpdate = do + st <- get + liftUpdate $ clearMain (scrRowsAsInteger st) (screenColumns st) + drawMode (mode st) + drawStatus + get + +{- Pattern match on the received mode and draw it in the screen. -} +drawMode :: Mode -> LazymailUpdate () +drawMode MaildirMode = get >>= \st -> drawSelectionList $ scrollBufferMD . maildirState $ st +drawMode IndexMode = get >>= \st -> drawSelectionList $ scrollBufferIn . indexState $ st +drawMode EmailMode = drawEmailHelper + +{- Draw a scrollable selection list -} +drawSelectionList [] = resetCurrentRow +drawSelectionList ((path, str):mds) = do + st <- get + (=<<) put $ liftUpdate $ do + moveCursor (curRowAsInteger st) (colPadAsInteger st) + if (selectedRow st == currentRow st) + then do + setColor $ selectionColorID . colorStyle $ st + drawString $ normalizeLen (screenColumns st) str + setColor $ baseColorID . colorStyle $ st + case (mode st) of + MaildirMode -> do + let mst = (maildirState st) { selectedMD = path } + return $ st { maildirState = mst } + IndexMode -> do + let ist = (indexState st) { selectedEmailPath = path } + return $ st { indexState = ist } + else do + drawSimpleRow st path str + return st + + st <- get + let limit = if statusBar st then (screenRows st) - 1 else screenRows st + if currentRow st < limit + then do + incrementCurrentRow + drawSelectionList mds + else + resetCurrentRow + +drawSimpleRow st path str | (mode st) == MaildirMode = drawString $ normalizeLen (screenColumns st) str + | (mode st) == IndexMode = + if isNew path + then do + setColor $ newEmailColorID . colorStyle $ st + drawCroppedString st str + setColor $ baseColorID . colorStyle $ st + else + drawCroppedString st str + +{- Empty the whole window. Useful when changing modes. -} +clearMain rows columns = do + drawEmptyLine 0 + moveCursor 0 0 + where + drawEmptyLine currentRow = do + moveCursor currentRow 0 + drawString $ replicate (columns) ' ' + when (currentRow < rows - 1) $ drawEmptyLine $ currentRow + 1 + +{- Helper function of drawMode -} +drawEmailHelper = do + drawEmailHeaders + + st <- get + let est = emailState st + put $ st { emailState = est { bodyStartRow = (currentRow st ) } } + let body = getBody $ currentEmail . emailState $ st + let maxRows = if statusBar st then (scrRowsAsInteger st) - 1 else scrRowsAsInteger st + liftUpdate $ + drawBody (curRowAsInteger st) (colPadAsInteger st) maxRows $ + drop (scrollRowEm est) $ emailLines est + resetCurrentRow + +{- Draw the email headers -} +drawEmailHeaders = do + st <- get + cfg <- ask + let hs = getHeaders $ currentEmail . emailState $ st + let parsedHeaders = parseHeaders hs 0 $ headersToShow cfg + + liftUpdate $ do + setColor $ headerColorID . colorStyle $ st + drawHeaders st (curRowAsInteger st) parsedHeaders + setColor $ baseColorID . colorStyle $ st + put $ st { currentRow = 1 + (length parsedHeaders) + (currentRow st) } + + where + parseHeaders _ _ [] = [] + parseHeaders headers row (h:hs)= do + let field = lookupField' h headers + case field of + Nothing -> parseHeaders headers row hs + Just f -> let p = capitalize h ++ ": " ++ (ppField f) + in p:parseHeaders headers (row + 1) hs + + capitalize str = (toUpper . head $ str):(tail str) + drawHeaders _ _ [] = return () + drawHeaders st row (h:hs) = do + moveCursor row (colPadAsInteger st) + drawCroppedString st h + drawHeaders st (row + 1) hs + +{- Draw the email body -} +drawBody _ _ _ [] = return () +drawBody row col maxRows (xs:xss) = do + moveCursor row col + drawString xs + when (row < maxRows) $ drawBody (row + 1) col maxRows xss + +{- Draw a status line with the current mode and other stuff -} +drawStatus = do + st <- get + liftUpdate $ do + moveCursor (scrRowsAsInteger st) 0 + setColor $ statusBarColorID . colorStyle $ st + drawString $ normalizeLen (screenColumns st - 1)$ concat $ drawStatusHelper (mode st) st -- Can't write in the last char - ncurses bug + setColor $ baseColorID . colorStyle $ st + +{- Status bar string for Maildir mode -} +drawStatusHelper MaildirMode st = + ["Maildir listing - " + , "(", show ((selectedRow st) + (scrollRowMD . maildirState $ st) + 1), "/" + , show (length $ detectedMDs . maildirState $ st), ")"] + +{- Status bar string for Index mode -} +drawStatusHelper IndexMode st = + ["mode: Index - " + , "(", show ((selectedRow st) + (scrollRowIn . indexState $ st) + 1), "/" + , show (currentInLen . indexState $ st), ")"] + +{- Status bar string for Email mode -} +drawStatusHelper EmailMode st = ["mode: Email"] + +{- Handle an event + - TODO: Handle the events in a cleaner way. -} +handleEvent :: LazymailCurses () +handleEvent = loop where + loop = do + w <- liftCurses $ defaultWindow + ev <- liftCurses $ getEvent w Nothing + st <- get + case ev of + Nothing -> loop + Just ev' -> + case ev' of + EventCharacter 'q' -> EH.previousMode (mode st) + + EventSpecialKey KeyUpArrow -> EH.decSelectedRow (mode st) + EventCharacter 'k' -> EH.decSelectedRow (mode st) + + EventSpecialKey KeyDownArrow -> EH.incSelectedRow (mode st) + EventCharacter 'j' -> EH.incSelectedRow (mode st) + + EventCharacter '\n' -> EH.changeMode (mode st) + EventSpecialKey KeyRightArrow -> EH.changeMode (mode st) + + _ -> loop + +{- Reset the current row to the beginning -} +resetCurrentRow = (=<<) put $ get >>= \st -> return $ st { currentRow = 0 } + +{- Advance the current row. Useful when drawing modes -} +incrementCurrentRow = (=<<) put $ get >>= \st -> return $ st { currentRow = (currentRow st) + 1 } + +{- Put the scroll at the top -} +resetScrollBuffer = do + st <- get + case (mode st) of + MaildirMode -> do + let mst = (maildirState st) { + scrollBufferMD = EH.scrollCrop 0 (screenRows st) $ detectedMDs . maildirState $ st } + put st { maildirState = mst} + IndexMode -> do + let ist = (indexState st) { + scrollBufferIn = EH.formatIndexModeRows st $ EH.scrollCrop 0 (screenRows st) $ selectedEmails . indexState $ st } + put st { indexState = ist } + +drawCroppedString st str = drawString $ normalizeLen (screenColumns st) str + +-- The type system complains if I want to use the same function for diferents monads +liftCurses = lift . lift +liftUpdate = lift . lift diff --git a/src/Lazymail/State.hs b/src/Lazymail/State.hs new file mode 100644 index 0000000..06353da --- /dev/null +++ b/src/Lazymail/State.hs @@ -0,0 +1,126 @@ +{- Lazymail state, and operations on it. + - + - Copyright 2013 Raúl Benencia <rul@kalgan.cc> + - + - Licensed under the GNU GPL version 3 or higher + - + -} + +module Lazymail.State where + +import Codec.MIME.Type(MIMEValue, nullMIMEValue) +import Text.ParserCombinators.Parsec.Rfc2822(Message, GenericMessage(..)) +import UI.NCurses(ColorID(..), defaultColorID) +import Network.Email.Mailbox(Flag(..), Flags) +import System.FilePath + +import Lazymail.Types + +initialState = LazymailState { + mode = MaildirMode + , basePath = "" + , screenRows = 0 + , screenColumns = 0 + , currentRow = 0 + , columnPadding = 0 + , exitRequested = False + , statusBar = True + , maildirState = initialMaildirState + , indexState = initialIndexState + , composeState = initialComposeState + , emailState = initialEmailState + , colorStyle = initialColorStyle +} + +initialMaildirState = MaildirState { + selectedRowMD = 0 + , selectedMD = "" + , detectedMDs = [] + , scrollRowMD = 0 + , scrollBufferMD = [] + , triggerUpdateMD = False +} + +initialIndexState = IndexState { + selectedRowIn = 0 + , selectedEmailPath = "" + , selectedEmails = [] + , scrollRowIn = 0 + , currentInLen = 0 + , scrollBufferIn = [] + , triggerUpdateIn = False +} + +initialEmailState = EmailState { + scrollRowEm = 0 + , bodyStartRow = 0 + , emailLines = [] + , currentEmail = nullMIMEValue +} + +initialComposeState = ComposeState { + composition = Nothing +} + +initialColorStyle = ColorStyle { + baseColorID = defaultColorID + , selectionColorID = defaultColorID + , statusBarColorID = defaultColorID + , headerColorID = defaultColorID + , newEmailColorID = defaultColorID +} + +scrColsAsInteger st = toInteger $ screenColumns st +scrRowsAsInteger st = toInteger $ screenRows st +curRowAsInteger st = toInteger $ currentRow st +colPadAsInteger st = toInteger $ columnPadding st + + +incrementSelectedRow st | (selectedRow st) < limit = + case (mode st) of + MaildirMode -> + let + sr = (selectedRowMD . maildirState) st + maildirState' = (maildirState st) { selectedRowMD = sr + 1 } + in + st { maildirState = maildirState' } + IndexMode -> + let + sr = (selectedRowIn . indexState) st + indexState' = (indexState st) { selectedRowIn = sr + 1 } + in + st { indexState = indexState' } + _ -> st + | otherwise = st + where + scrRows = screenRows st + curInLen = length $ selectedEmails . indexState $ st + curMDLen = length $ detectedMDs . maildirState $ st + limit' = case (mode st) of + MaildirMode -> if curMDLen < scrRows then curMDLen - 1 else scrRows + IndexMode -> if curInLen < scrRows then curInLen - 1 else scrRows + limit = if (statusBar st) && (limit' == scrRows) + then fromIntegral $ limit' - 2 + else fromIntegral limit' + +decrementSelectedRow st | (selectedRow st) > 0 = + case (mode st) of + MaildirMode -> + let + sr = (selectedRowMD . maildirState) st + maildirState' = (maildirState st) { selectedRowMD = sr - 1 } + in + st { maildirState = maildirState' } + IndexMode -> + let + sr = (selectedRowIn . indexState) st + indexState' = (indexState st) { selectedRowIn = sr - 1 } + in + st { indexState = indexState' } + _ -> st + | otherwise = st + +selectedRow st = case (mode st) of + MaildirMode -> selectedRowMD . maildirState $ st + IndexMode -> selectedRowIn . indexState $ st + diff --git a/src/Lazymail/Types.hs b/src/Lazymail/Types.hs new file mode 100644 index 0000000..fb30f91 --- /dev/null +++ b/src/Lazymail/Types.hs @@ -0,0 +1,128 @@ +{- Common types of Lazymail + - + - Copyright 2013 Raúl Benencia <rul@kalgan.cc> + - + - Licensed under the GNU GPL version 3 or higher + -} + +module Lazymail.Types where + +import Codec.MIME.Type(MIMEValue(..)) +import Control.Monad.Reader(ReaderT) +import Control.Monad.State(StateT) +import Data.DateTime(DateTime) +import System.FilePath(FilePath) +import System.IO(Handle) +import UI.NCurses(Curses, Update, Color(..), ColorID, Event(..)) + +type LazymailUpdate = ReaderT LazymailConfig (StateT LazymailState Update) +type LazymailCurses = ReaderT LazymailConfig (StateT LazymailState Curses) + +{- Lazymail monad is a ReaderT around a StateT with IO at the bottom of the + - stack. + -} +type Lazymail = ReaderT LazymailConfig (StateT LazymailState IO) + +data LazymailConfig = LazymailConfig { + baseColor :: (Color, Color) -- (foreground, background) + , selectionColor :: (Color, Color) + , statusBarColor :: (Color, Color) + , headerColor :: (Color, Color) + , newEmailColor :: (Color, Color) + , showStatusBar :: Bool + , initialPath :: FilePath + , filterMaildirsHook :: [FilePath] -> IO [FilePath] + , indexDateFormat :: String + , headersToShow :: [String] + , globalKeymaps :: [Keymap] + , maildirModeKeymap :: [Keymap] + , indexModeKeymap :: [Keymap] + , emailModeKeymap :: [Keymap] + , composeModeKeymap :: [Keymap] +} + +data Email = Email { + emailValue :: MIMEValue + , emailDate :: DateTime + , emailPath :: FilePath + , emailHandle :: Handle +} + +instance Eq Email where + (Email _ _ fp1 _) == (Email _ _ fp2 _) = fp1 == fp2 + +instance Ord Email where + (Email _ d1 _ _) `compare` (Email _ d2 _ _) = d1 `compare` d2 + +data Mode = MaildirMode | IndexMode | EmailMode | ComposeMode + deriving (Show, Eq) + +type Maildir = FilePath + +data Flag = NEW + | SEEN + | ANSWERED + | FLAGGED + | DELETED + | DRAFT + | FORWARDED + | OTHERFLAG String + deriving (Eq) + +type Flags = [Flag] + +data LazymailState = LazymailState { + mode :: Mode + , basePath :: FilePath + , screenRows :: Int + , screenColumns :: Int + , currentRow :: Int + , columnPadding :: Int + , exitRequested :: Bool + , statusBar :: Bool + , maildirState :: MaildirState + , indexState :: IndexState + , emailState :: EmailState + , composeState :: ComposeState + , colorStyle :: ColorStyle +} + +data MaildirState = MaildirState { + selectedRowMD :: Int + , selectedMD :: String + , detectedMDs :: [(FilePath, String)] + , scrollRowMD :: Int + , scrollBufferMD :: [(FilePath, String)] + , triggerUpdateMD :: Bool +} + +data IndexState = IndexState { + selectedRowIn :: Int + , selectedEmailPath :: FilePath + , selectedEmails :: [Email] + , scrollRowIn :: Int + , currentInLen :: Int + , scrollBufferIn :: [(FilePath, String)] + , triggerUpdateIn :: Bool +} + +data ComposeState = ComposeState { + composition :: Maybe String +} + +data EmailState = EmailState { + scrollRowEm :: Int + , bodyStartRow :: Int + , emailLines :: [String] + , currentEmail :: MIMEValue +} + +data ColorStyle = ColorStyle { + baseColorID :: ColorID + , selectionColorID :: ColorID + , statusBarColorID :: ColorID + , headerColorID :: ColorID + , newEmailColorID :: ColorID +} + +type Keymap = ([Event], LazymailCurses ())
\ No newline at end of file |