From 3bd3fd2c6eae2f36f69f247403421e8cf8226394 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ra=C3=BAl=20Benencia?= Date: Thu, 5 Sep 2013 19:57:02 -0300 Subject: Moved all code to src/ --- Codec/Text/Rfc1342.hs | 57 ---------- Lazymail/Config.hs | 55 ---------- Lazymail/Email.hs | 132 ----------------------- Lazymail/Handlers.hs | 232 --------------------------------------- Lazymail/Keymap.hs | 16 --- Lazymail/Maildir.hs | 142 ------------------------ Lazymail/Print.hs | 80 -------------- Lazymail/Screen.hs | 268 ---------------------------------------------- Lazymail/State.hs | 126 ---------------------- Lazymail/Types.hs | 128 ---------------------- Main.hs | 49 --------- src/Codec/Text/Rfc1342.hs | 57 ++++++++++ src/Lazymail/Config.hs | 55 ++++++++++ src/Lazymail/Email.hs | 132 +++++++++++++++++++++++ src/Lazymail/Handlers.hs | 232 +++++++++++++++++++++++++++++++++++++++ src/Lazymail/Keymap.hs | 16 +++ src/Lazymail/Maildir.hs | 142 ++++++++++++++++++++++++ src/Lazymail/Print.hs | 80 ++++++++++++++ src/Lazymail/Screen.hs | 268 ++++++++++++++++++++++++++++++++++++++++++++++ src/Lazymail/State.hs | 126 ++++++++++++++++++++++ src/Lazymail/Types.hs | 128 ++++++++++++++++++++++ src/Main.hs | 49 +++++++++ 22 files changed, 1285 insertions(+), 1285 deletions(-) delete mode 100644 Codec/Text/Rfc1342.hs delete mode 100644 Lazymail/Config.hs delete mode 100644 Lazymail/Email.hs delete mode 100644 Lazymail/Handlers.hs delete mode 100644 Lazymail/Keymap.hs delete mode 100644 Lazymail/Maildir.hs delete mode 100644 Lazymail/Print.hs delete mode 100644 Lazymail/Screen.hs delete mode 100644 Lazymail/State.hs delete mode 100644 Lazymail/Types.hs delete mode 100644 Main.hs create mode 100644 src/Codec/Text/Rfc1342.hs create mode 100644 src/Lazymail/Config.hs create mode 100644 src/Lazymail/Email.hs create mode 100644 src/Lazymail/Handlers.hs create mode 100644 src/Lazymail/Keymap.hs create mode 100644 src/Lazymail/Maildir.hs create mode 100644 src/Lazymail/Print.hs create mode 100644 src/Lazymail/Screen.hs create mode 100644 src/Lazymail/State.hs create mode 100644 src/Lazymail/Types.hs create mode 100644 src/Main.hs diff --git a/Codec/Text/Rfc1342.hs b/Codec/Text/Rfc1342.hs deleted file mode 100644 index f6d8fe2..0000000 --- a/Codec/Text/Rfc1342.hs +++ /dev/null @@ -1,57 +0,0 @@ -{- A simple RFC1342 decoder. - - - - Copyright 2013 Raúl Benencia - - - - Licensed under the GNU GPL version 3 or higher - - - -} -module Codec.Text.Rfc1342 (decodeField) where - -import qualified Codec.Binary.Base64 as B64 -import qualified Codec.Binary.QuotedPrintable as QP - -import Data.Char (toLower, isSpace, chr) -import Data.List(isPrefixOf) -import Data.Word (Word8) - -import Data.Encoding(decodeString) - --- Encoding imports. If you want to support more encodings, just add'em here. -import Data.Encoding.UTF8 -import Data.Encoding.ISO88591 -import Data.Encoding.ISO88592 -import Data.Encoding.ISO88598 -import Data.Encoding.ISO88599 - -decodeField :: String -> String -decodeField ('=':'?':cs) = decodeWithCharset dec rest - where (encoding, rest) = span (\c -> c /= '?') cs - dec = case (map toLower encoding) of - "utf-8" -> decodeString UTF8 - "iso-8859-1" -> decodeString ISO88591 - "iso-8859-2" -> decodeString ISO88592 - "iso-8859-8" -> decodeString ISO88598 - "iso-8859-9" -> decodeString ISO88599 - _ -> id -decodeField [] = [] -decodeField (c:cs) = c:decodeField cs - -decodeWithCharset dec [] = [] -decodeWithCharset dec ('?':c:'?':cs) | toLower c == 'b' = dataDecodeWith B64.decode - | toLower c == 'q' = dataDecodeWith QP.decode - | otherwise = cs - where (encoded, rest') = span (\c -> c /= '?') cs - rest = if "?=" `isPrefixOf` rest' - then drop 2 rest' - else rest' - dataDecodeWith datadec = (_2spc . dec . unwrap . datadec $ encoded) ++ decodeField rest -- ++ (decodeField $ dropWhile isSpace rest) - -unwrap :: Maybe [Word8] -> String -unwrap Nothing = [] -unwrap (Just str) = bytesToString str - -bytesToString :: [Word8] -> String -bytesToString = map (chr . fromIntegral) - --- Sometimes an underscore represents the SPACE character -_2spc = map (\x -> if x == '_' then ' ' else x) \ No newline at end of file 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 - - - - 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 - - - - 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 "" $ 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 - - - - 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 - - - - 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 - - - - 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 - - - - 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 - - - - 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 - - - - 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 diff --git a/Main.hs b/Main.hs deleted file mode 100644 index 2144d9c..0000000 --- a/Main.hs +++ /dev/null @@ -1,49 +0,0 @@ -{- Main module - - - - Copyright 2013 Raúl Benencia - - - - Licensed under the GNU GPL version 3 or higher - - - -} - -module Main (main) where - -import Control.Monad.Reader(runReaderT) -import Control.Monad.State(runStateT) -import System.Environment -import System.Exit -import System.FilePath(takeDirectory) - -import Lazymail.Config(customConfig) -import Lazymail.Email -import Lazymail.Maildir -import Lazymail.Screen -import Lazymail.State -import Lazymail.Types - -parse ["-h"] = usage >> exit -parse ["--help"] = usage >> exit -parse ["-v"] = version >> exit -parse ["--version"] = version >> exit -parse _ = run entryPoint - -run :: Lazymail a -> IO (a, LazymailState) -run k = - let config = customConfig - state = initialState { basePath = initialPath config } - in runStateT (runReaderT k config) state - -usage = putStrLn . unlines $ usageText where - usageText = ["Usage: ./Main [-vh] " - ," where is a directory with Maildirs, or a Maildir itself." - ," Lazymail will recursively search for Maildirs. "] - -version = putStrLn "Haskell lazymail 0.0001" -exit = exitWith ExitSuccess -die = exitWith (ExitFailure 1) - -main :: IO () -main = do - args <- getArgs - parse args - putStrLn "Game over!" diff --git a/src/Codec/Text/Rfc1342.hs b/src/Codec/Text/Rfc1342.hs new file mode 100644 index 0000000..f6d8fe2 --- /dev/null +++ b/src/Codec/Text/Rfc1342.hs @@ -0,0 +1,57 @@ +{- A simple RFC1342 decoder. + - + - Copyright 2013 Raúl Benencia + - + - Licensed under the GNU GPL version 3 or higher + - + -} +module Codec.Text.Rfc1342 (decodeField) where + +import qualified Codec.Binary.Base64 as B64 +import qualified Codec.Binary.QuotedPrintable as QP + +import Data.Char (toLower, isSpace, chr) +import Data.List(isPrefixOf) +import Data.Word (Word8) + +import Data.Encoding(decodeString) + +-- Encoding imports. If you want to support more encodings, just add'em here. +import Data.Encoding.UTF8 +import Data.Encoding.ISO88591 +import Data.Encoding.ISO88592 +import Data.Encoding.ISO88598 +import Data.Encoding.ISO88599 + +decodeField :: String -> String +decodeField ('=':'?':cs) = decodeWithCharset dec rest + where (encoding, rest) = span (\c -> c /= '?') cs + dec = case (map toLower encoding) of + "utf-8" -> decodeString UTF8 + "iso-8859-1" -> decodeString ISO88591 + "iso-8859-2" -> decodeString ISO88592 + "iso-8859-8" -> decodeString ISO88598 + "iso-8859-9" -> decodeString ISO88599 + _ -> id +decodeField [] = [] +decodeField (c:cs) = c:decodeField cs + +decodeWithCharset dec [] = [] +decodeWithCharset dec ('?':c:'?':cs) | toLower c == 'b' = dataDecodeWith B64.decode + | toLower c == 'q' = dataDecodeWith QP.decode + | otherwise = cs + where (encoded, rest') = span (\c -> c /= '?') cs + rest = if "?=" `isPrefixOf` rest' + then drop 2 rest' + else rest' + dataDecodeWith datadec = (_2spc . dec . unwrap . datadec $ encoded) ++ decodeField rest -- ++ (decodeField $ dropWhile isSpace rest) + +unwrap :: Maybe [Word8] -> String +unwrap Nothing = [] +unwrap (Just str) = bytesToString str + +bytesToString :: [Word8] -> String +bytesToString = map (chr . fromIntegral) + +-- Sometimes an underscore represents the SPACE character +_2spc = map (\x -> if x == '_' then ' ' else x) \ No newline at end of file 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 + - + - 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 + - + - 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 "" $ 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 + - + - 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 + - + - 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 + - + - 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 + - + - 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 + - + - 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 + - + - 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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..2144d9c --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,49 @@ +{- Main module + - + - Copyright 2013 Raúl Benencia + - + - Licensed under the GNU GPL version 3 or higher + - + -} + +module Main (main) where + +import Control.Monad.Reader(runReaderT) +import Control.Monad.State(runStateT) +import System.Environment +import System.Exit +import System.FilePath(takeDirectory) + +import Lazymail.Config(customConfig) +import Lazymail.Email +import Lazymail.Maildir +import Lazymail.Screen +import Lazymail.State +import Lazymail.Types + +parse ["-h"] = usage >> exit +parse ["--help"] = usage >> exit +parse ["-v"] = version >> exit +parse ["--version"] = version >> exit +parse _ = run entryPoint + +run :: Lazymail a -> IO (a, LazymailState) +run k = + let config = customConfig + state = initialState { basePath = initialPath config } + in runStateT (runReaderT k config) state + +usage = putStrLn . unlines $ usageText where + usageText = ["Usage: ./Main [-vh] " + ," where is a directory with Maildirs, or a Maildir itself." + ," Lazymail will recursively search for Maildirs. "] + +version = putStrLn "Haskell lazymail 0.0001" +exit = exitWith ExitSuccess +die = exitWith (ExitFailure 1) + +main :: IO () +main = do + args <- getArgs + parse args + putStrLn "Game over!" -- cgit v1.2.3