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