towards mime library

5 files changed, 90 insertions, 54 deletions

diff --git a/Email.hs b/Email.hs
index 4601aa5..c1c524f 100644
--- a/Email.hs
+++ b/Email.hs
@@ -7,16 +7,75 @@
  -}
 module Email where
 
-import Network.Email.Mailbox(Flag(..), Flags)
+import Codec.MIME.Type(MIMEValue(..), MIMEContent(..))
+import Data.Char(toLower)
+import Data.List(find)
 
-import Text.Parsec.Error(ParseError)
+getBody :: MIMEValue -> String
+getBody msg =
+  case mime_val_content msg of
+    Single c -> c
+    _        -> "Buggity Buggity Buggity!"
+
+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
 
-data Email = Email { emailPath :: String
-                   , parsedEmail :: Message
-                   }
-
 parseEmail :: String -> Message
 parseEmail msg = unwrapEmail $ parse message "<stdin>" $  fixEol msg
 
@@ -49,27 +108,9 @@ getResentMessageID fs = do { ResentMessageID f <- fs; f }
 getBody (Message _ []) = "Empty body"
 getBody (Message _ body) = body
 
--- | 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
-
 -- 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 []               = []
-
---data DescriptionPP = DescriptionPP {
---   ppOrder :: [String] -> [String]
--- }
-
-
--- emailDescription = emailDescriptionWithPP defaultDescriptionPP
-
--- emailDescriptionWithPP pp
\ No newline at end of file
+fixEol []               = []-}
diff --git a/Handlers.hs b/Handlers.hs
index 3e27b79..503358b 100644
--- a/Handlers.hs
+++ b/Handlers.hs
@@ -7,16 +7,18 @@
 
 module Handlers where
 
-import Data.List(intercalate)
+import Codec.MIME.Parse(parseMIMEMessage)
+import Codec.MIME.Type(MIMEValue(..))
 import Control.Monad.State
-import Data.List(stripPrefix)
+import Data.List(intercalate, stripPrefix)
 import System.FilePath(FilePath, takeFileName, dropTrailingPathSeparator)
+import qualified System.IO.UTF8 as UTF8
 
-import Email(parseEmail, getFields, getSubject, getFrom, getBody, formatBody)
+--import Email(parseEmail, getFields, getSubject, getFrom, getBody, formatBody)
+import Email(lookupField, getBody, formatBody)
 import Maildir
 import Print
 import State
-import qualified System.IO.UTF8 as UTF8
 import Types (LazymailCurses)
 
 previousMode :: Mode -> LazymailCurses ()
@@ -32,7 +34,7 @@ changeMode EmailMode   = return ()
 changeMode IndexMode   = do
   st <- get
   msg <- liftIO $ UTF8.readFile . selectedEmailPath . indexState $ st
-  let email = parseEmail msg
+  let email = parseMIMEMessage msg
   let body = getBody $ email
   let el = formatBody body $ screenColumns st
   let est = (emailState st) { currentEmail = email, emailLines = el, scrollRowEm = 0 }
@@ -151,12 +153,12 @@ scrollCrop top rows xs = take rows $ drop top xs
 formatIndexModeRows st = mapM formatRow where
   formatRow fp = do
     msg <- UTF8.readFile fp
-    let email = parseEmail msg
-    let fs = getFields email
+    let email = parseMIMEMessage msg
+    let hs = mime_val_headers email
     let str = normalizeLen (screenColumns st) $ intercalate ppSep $
               [ ppFlags . getFlags $ fp
-              , ppIndexNameAddr . getFrom $ fs
-              , ppSubject . getSubject $ fs
+              , normalizeLen fromLen $ ppField $ lookupField "from" hs
+              , ppField $ lookupField "subject" hs
               ]
     return (fp, str)
 
diff --git a/Print.hs b/Print.hs
index 8916e55..8f40491 100644
--- a/Print.hs
+++ b/Print.hs
@@ -16,20 +16,12 @@ import Text.ParserCombinators.Parsec.Rfc2822(NameAddr(..))
 import Email
 import Rfc1342
 
-nameLen = 20
-ppNameAddr nas = intercalate ", " $ map ppNameAddr' nas
-  where ppNameAddr' na = case nameAddr_name na of
-                           Nothing -> nameAddr_addr na
-                           Just n  -> unquote (decodeField n) ++ " <" ++ nameAddr_addr na ++ ">"
-
-ppIndexNameAddr nas = normalizeLen nameLen $ concat $ map ppNameAddr' nas
-  where ppNameAddr' na = case nameAddr_name na of
-                           Nothing -> nameAddr_addr na
-                           Just n  -> unquote (decodeField n)
-
 unquote xs= if (head xs == '"' && last xs == '"') then (tail . init) xs else xs
 
-ppSubject = flat . decodeField
+ppField = flat . decodeField
+
+fromLen :: Int
+fromLen = 20
 
 flat xs = intercalate " " $ map (dropWhile isSpace) $ map (filter (/= '\r')) $ lines xs
 
diff --git a/Screen.hs b/Screen.hs
index eaa87cf..90954b1 100644
--- a/Screen.hs
+++ b/Screen.hs
@@ -9,12 +9,12 @@
 
 module Screen where
 
+import Codec.MIME.Type(MIMEValue(..))
 import Control.Monad.Trans(liftIO)
 import Control.Monad.Reader
 import Control.Monad.State
 import Data.List(isPrefixOf)
 import System.Exit
-import Text.ParserCombinators.Parsec.Rfc2822(Message(..))
 import UI.NCurses
 
 -- Local imports
@@ -22,7 +22,7 @@ import Config
 import qualified Handlers as EH
 import Lazymail
 import Maildir
-import Email
+import Email(lookupField, getBody, getHeaders)
 import Print
 import Rfc1342
 import State
@@ -148,16 +148,16 @@ drawEmailHelper = do
 drawEmailHeader = do
   st <- get
   liftUpdate $ do
-    let fs = getFields $ currentEmail . emailState $ st
+    let hs = getHeaders $ currentEmail . emailState $ st
     let cropWith xs = normalizeLen $ (screenColumns st) - (length xs)
     let row = curRowAsInteger st
     setColor $ headerColorID . colorStyle $ st
     moveCursor row (colPadAsInteger st)
-    drawCroppedString st $ ("From: " ++) $ ppNameAddr . getFrom $ fs
+    drawCroppedString st $ ("From: " ++) . ppField $ lookupField "from" hs
     moveCursor (row + 1) (colPadAsInteger st)
-    drawCroppedString st $ ("To: " ++) $ ppNameAddr . getTo $ fs
+    drawCroppedString st $ ("To: " ++) . ppField $ lookupField "to" hs
     moveCursor (row + 2) (colPadAsInteger st)
-    drawCroppedString st $ ("Subject: " ++) $ ppSubject . getSubject $ fs
+    drawCroppedString st $ ("Subject: " ++) . ppField $ lookupField "subject" hs
     setColor $ baseColorID . colorStyle $ st
   put $ st { currentRow = (4 + currentRow st) }
 
diff --git a/State.hs b/State.hs
index d04871f..357a516 100644
--- a/State.hs
+++ b/State.hs
@@ -8,6 +8,7 @@
 
 module 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)
@@ -56,7 +57,7 @@ data EmailState = EmailState {
     scrollRowEm    :: Int
   , bodyStartRow   :: Int
   , emailLines     :: [String]
-  , currentEmail   :: Message
+  , currentEmail   :: MIMEValue
 }
 
 data ColorStyle = ColorStyle {
@@ -103,7 +104,7 @@ initialEmailState = EmailState {
     scrollRowEm    = 0
   , bodyStartRow  = 0
   , emailLines     = []
-  , currentEmail   = Message [] "Dummy email"
+  , currentEmail   = nullMIMEValue
 }
 
 initialComposeState = ComposeState {