diff options
Diffstat (limited to 'Lazymail')
| -rw-r--r-- | Lazymail/Config.hs | 55 | ||||
| -rw-r--r-- | Lazymail/Email.hs | 132 | ||||
| -rw-r--r-- | Lazymail/Handlers.hs | 232 | ||||
| -rw-r--r-- | Lazymail/Keymap.hs | 16 | ||||
| -rw-r--r-- | Lazymail/Maildir.hs | 142 | ||||
| -rw-r--r-- | Lazymail/Print.hs | 80 | ||||
| -rw-r--r-- | Lazymail/Screen.hs | 268 | ||||
| -rw-r--r-- | Lazymail/State.hs | 126 | ||||
| -rw-r--r-- | Lazymail/Types.hs | 128 |
9 files changed, 0 insertions, 1179 deletions
diff --git a/Lazymail/Config.hs b/Lazymail/Config.hs deleted file mode 100644 index 2566bc9..0000000 --- a/Lazymail/Config.hs +++ /dev/null @@ -1,55 +0,0 @@ -{- 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/Lazymail/Email.hs b/Lazymail/Email.hs deleted file mode 100644 index fc63a89..0000000 --- a/Lazymail/Email.hs +++ /dev/null @@ -1,132 +0,0 @@ -{- 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/Lazymail/Handlers.hs b/Lazymail/Handlers.hs deleted file mode 100644 index b0b1165..0000000 --- a/Lazymail/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 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/Lazymail/Keymap.hs b/Lazymail/Keymap.hs deleted file mode 100644 index 1cef1b1..0000000 --- a/Lazymail/Keymap.hs +++ /dev/null @@ -1,16 +0,0 @@ -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/Lazymail/Maildir.hs b/Lazymail/Maildir.hs deleted file mode 100644 index 1793105..0000000 --- a/Lazymail/Maildir.hs +++ /dev/null @@ -1,142 +0,0 @@ -{- 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/Lazymail/Print.hs b/Lazymail/Print.hs deleted file mode 100644 index 15e9df1..0000000 --- a/Lazymail/Print.hs +++ /dev/null @@ -1,80 +0,0 @@ -{- 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/Lazymail/Screen.hs b/Lazymail/Screen.hs deleted file mode 100644 index 699f84e..0000000 --- a/Lazymail/Screen.hs +++ /dev/null @@ -1,268 +0,0 @@ -{- 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/Lazymail/State.hs b/Lazymail/State.hs deleted file mode 100644 index 06353da..0000000 --- a/Lazymail/State.hs +++ /dev/null @@ -1,126 +0,0 @@ -{- 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/Lazymail/Types.hs b/Lazymail/Types.hs deleted file mode 100644 index fb30f91..0000000 --- a/Lazymail/Types.hs +++ /dev/null @@ -1,128 +0,0 @@ -{- 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 |