diff --git a/Email.hs b/Email.hs new file mode 100644 --- /dev/null +++ b/Email.hs @@ -0,0 +1,145 @@ +-------------------------------------------------------------------- +-- | +-- Module : Email +-- Copyright : (c) Nicolas Pouillard 2008, 2009, 2010, 2011 +-- License : BSD3 +-- +-- Maintainer: Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +{-# LANGUAGE BangPatterns, Rank2Types, TemplateHaskell, TypeOperators, + OverloadedStrings, GeneralizedNewtypeDeriving #-} +module Email where + +import Control.Applicative +import qualified Data.ByteString.Lazy.Char8 as C +import qualified Data.ByteString.Lazy as B +{- TMP-NO-MIME +import Codec.MIME.Type (MIMEValueB) +import Codec.MIME.Parse (parseMIMEBody, safeParseMIMEBodyByteString, WithoutCRLF(..)) +import System.IO.Unsafe (unsafePerformIO) +import Debug.Trace (trace) +-} +import Text.ParserCombinators.Parsec.Rfc2822 (Field(..), fields) +import Text.ParserCombinators.Parsec (parse) +import EOL (fixCrlfS {- TMP-NO-MIME, fixCrlfB -}) +import System.IO.Error (isDoesNotExistError) +import System.Environment (getEnv) +import Codec.Mbox (Mbox(..), mboxMsgBody) +import Data.Maybe (listToMaybe, fromMaybe) +import Data.Char (toLower) +import Data.Label + +data Email = Email { _emailFields :: [Field] + -- TMP-NO-MIME , _emailContent :: MIMEValueB + , _emailContent :: B.ByteString + , _rawEmail :: B.ByteString + } + deriving (Show) + +$(mkLabels [''Email]) + +myCunpack :: C.ByteString -> String +myCunpack = C.unpack +--myCunpack = unfoldr C.uncons +--myCunpack ys = case C.uncons ys of { Nothing -> [] ; Just (x,xs) -> x : myCunpack xs } + +{- + Since parsing the full message is two slow, one first extract fields. + + -- the old version + > readEmail = either (error . show) id . parse message "" . fixCrlfS . myCunpack + -} + +readFields :: B.ByteString -> [Field] +readFields input = + either err id . parse fields "" . fixCrlfS . myCunpack $ input + where err e = error $ "Error in the following message < [Field] +readFieldsOnly inp = readFields . fst . fromMaybe err . splitAtNlNl $ inp + where err = error "readFieldsOnly: parse error" + +{- +readField :: B.ByteString -> Field +readField input = + either err id . parse field "" . myCunpack $ input + where err e = error $ "Error in the following line:\n " ++ show (myCunpack input) ++ "\n\n" ++ show e + +readFields :: B.ByteString -> [Field] +readFields = map (readField . (`C.append` (C.pack "\r\n"))) . C.lines +-} + +safeGetEnv :: String -> IO (Maybe String) +safeGetEnv s = (Just <$> getEnv s) `catch` \e -> if isDoesNotExistError e + then return Nothing + else ioError e -- I'm wondering if this could happen + +{- TMP-NO-MIME +{-# NOINLINE dynParseMIMEBody #-} +dynParseMIMEBody :: [(String, String)] -> B.ByteString -> MIMEValueB +dynParseMIMEBody = unsafePerformIO $ + do mode <- safeGetEnv "MIME_PARSING_MODE" + return $ case mode of + Just "string" -> \hdr -> fmap C.pack . parseMIMEBody hdr . fixCrlfS . C.unpack + Just "bytestring" -> \hdr -> parseMIMEBody hdr . fixCrlfB + Just "safe" -> \hdr -> safeParseMIMEBodyByteString hdr . fixCrlfB + Just "bytestringcrlf" -> \hdr -> fmap withoutCRLF . parseMIMEBody hdr . WithoutCRLF + Just other -> trace ("unknown MIME_PARSING_MODE " ++ other) parseMIMEBody + Nothing -> parseMIMEBody +-} + +splitAtNlNl :: B.ByteString -> Maybe (B.ByteString, B.ByteString) +splitAtNlNl !orig = go 0 orig + where go !count !input = do + off <- (+1) <$> C.elemIndex '\n' input + let i' = C.drop off input + case C.uncons i' of + Nothing -> Just (C.take (off + count) orig, C.empty) + Just ('\n', i'') -> Just (C.take (off + count) orig, i'') + _ -> go (off + count) i' + +readEmail :: B.ByteString -> Email +readEmail !orig = mkEmail $ fromMaybe (error "readEmail: parse error") $ splitAtNlNl orig + where + mkEmail ~(flds, body) = + Email { _emailFields = headers + --, emailContent = parseMIMEBody optional_headers (fixCrlfB body) + --, emailContent = fmap C.pack $ parseMIMEBody optional_headers (fixCrlfS (C.unpack body)) + --, emailContent = safeParseMIMEBodyByteString optional_headers (fixCrlfB body) + {- TMP-NO-MIME + , _emailContent = dynParseMIMEBody optional_headers body + -} + , _emailContent = body + , _rawEmail = orig } + where headers = readFields flds + {- TMP-NO-MIME + optional_headers = [ (k,v) | OptionalField k v <- headers ] + -} + +readMboxEmails :: Mbox B.ByteString -> [Email] +readMboxEmails = map (readEmail . get mboxMsgBody) . mboxMessages + +stringOfField :: Field -> (String, String) +stringOfField (MessageID x) = ("message-id", fromMaybe (error "impossible: Email.stringOfField") $ unquote x) +stringOfField (Subject x) = ("subject", x) +stringOfField (OptionalField x y) = (map toLower x, y) +stringOfField x = ("x-unknown", show x) -- TODO + +messageId :: Email -> Maybe String +messageId msg = listToMaybe [ mid | MessageID mid <- get emailFields msg ] + +messageSubject :: Email -> Maybe String +messageSubject msg = listToMaybe [ mid | Subject mid <- get emailFields msg ] +{- + head ([show subject | Subject subject <- flds ] + ++ ["(malformed subject) " ++ show subject | OptionalField "Subject" subject <- flds ] + ++ ["no subject, body: " ++ ellipse 40 (show msg)]) +-} +unquote :: String -> Maybe String +unquote ('<':xs) = listToMaybe [ys | zs == ">"] where (ys, zs) = break (=='>') xs +unquote _ = Nothing diff --git a/EmailFmt.hs b/EmailFmt.hs new file mode 100644 --- /dev/null +++ b/EmailFmt.hs @@ -0,0 +1,74 @@ +-------------------------------------------------------------------- +-- | +-- Module : EmailFmt +-- Copyright : (c) Nicolas Pouillard 2010, 2011 +-- License : BSD3 +-- +-- Maintainer: Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +{-# LANGUAGE Rank2Types, + OverloadedStrings, GeneralizedNewtypeDeriving #-} +module EmailFmt where + +import Control.Applicative +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.Lazy.Internal as B +import System.Console.GetOpt (OptDescr(..),ArgDescr(..)) +import System.IO (Handle, stdout, hPutChar) +import Codec.Mbox (Mbox(..), MboxMessage(..), showMbox) +import Data.Maybe (fromMaybe) +import Email +import FmtComb + +data ShowFormat = MboxFmt + | FmtComb FmtComb + +fmtOpt :: (forall err. String -> err) -> (ShowFormat -> a) -> OptDescr a +fmtOpt usage f = Option "f" ["fmt"] (ReqArg (f . parseFmt) "FMT") desc + where parseFmt = fromMaybe (usage "Bad display format") . mayReadShowFormat + desc = "Choose the display format" + +defaultShowFormat :: ShowFormat +defaultShowFormat = FmtComb oneLinerF + +mayReadShowFormat :: String -> Maybe ShowFormat +mayReadShowFormat "mbox" = Just MboxFmt +mayReadShowFormat xs = FmtComb <$> mayReadShowFmts xs + +showFormatsDoc :: String +showFormatsDoc = unlines $ + ["Message formatting:" + ,"" + ," fmt ::= 'mbox'" + ," | ( '%(' ( '.')* ')' | )*" + ," name ::="] ++ + map ((" | '" ++) . (++ "'") . fst) fmtCombs ++ + [" fct ::="] ++ + map ((" | '" ++) . (++ "'") . fst) fmtMods ++ + map ((" | '" ++) . (++ "' ") . fst) intFmtMods ++ + ["" + ," * one : One line per email with: subject, mimetype and message ID (default)" + ," * mbox: Write emails in mbox format" + ," * from: One line header of mbox format [as 'From %(mboxmsgsender) %(mboxmsgtime)']" + ] ++ + map (\ (x, (_, y)) -> " * " ++ x ++ ": " ++ y) fmtMods ++ + map (\ (x, (_, y)) -> " * " ++ x ++ ": " ++ y) intFmtMods + +hPutB' :: Handle -> B.ByteString -> IO () +hPutB' h = go + where go B.Empty = return () + go (B.Chunk c cs) = S.hPut h c >> go cs + +putStrLnB' :: B.ByteString -> IO () +putStrLnB' s = hPutB' stdout s >> hPutChar stdout '\n' + +putEmails :: ShowFormat -> [(Email,MboxMessage B.ByteString)] -> IO () +putEmails MboxFmt = B.putStr . showMbox . Mbox . map snd +--putEmails (FmtComb fmt) = mapM_ (B.putStrLn . renderFmtComb fmt) -- it's seems to compute a big part (all?) of the list before starting to print (when using mbox-grep for instance) +putEmails (FmtComb fmt) = mapM_ (putStrLnB' . renderFmtComb fmt) + diff --git a/FmtComb.hs b/FmtComb.hs new file mode 100644 --- /dev/null +++ b/FmtComb.hs @@ -0,0 +1,172 @@ +-------------------------------------------------------------------- +-- | +-- Module : FmtComb +-- Copyright : (c) Nicolas Pouillard 2010, 2011 +-- License : BSD3 +-- +-- Maintainer: Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +{-# LANGUAGE BangPatterns, + OverloadedStrings, GeneralizedNewtypeDeriving #-} +module FmtComb where + +import Control.Applicative +import Control.Monad.Reader +import qualified Data.ByteString.Lazy.Char8 as C +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as B +{- TMP-NO-MIME +import Codec.MIME.Type (MIMEValue(..), Type(..), showMIMEType) +-} +import Codec.Mbox (MboxMessage(..), showMboxMessage) +import qualified Data.Digest.Pure.MD5 as MD5 (md5) +import Data.Maybe (fromMaybe) +import Data.List (intersperse) +import Data.Monoid (Monoid(..)) +import Data.Char (isSpace) +import Email + +type Message = (Email, MboxMessage B.ByteString) + +newtype ReaderMsg a = ReaderMsg { runReaderMsg :: Reader Message a } + deriving (Monad, Functor, Applicative, MonadReader Message) + +type FmtComb = ReaderMsg B.ByteString +type FmtMod = FmtComb -> FmtComb + +instance Monoid w => Monoid (ReaderMsg w) where + mempty = pure mempty + mappend x y = mappend <$> x <*> y + +evalReaderMsg :: Message -> ReaderMsg a -> a +evalReaderMsg msg = flip runReader msg . runReaderMsg + +-- read/show extras +mayRead :: Read a => String -> Maybe a +mayRead s = case reads s of + [(x, "")] -> Just x + _ -> Nothing + +showC ::Show a => a -> B.ByteString +showC = C.pack . show + +viaS :: (S.ByteString -> S.ByteString) -> B.ByteString -> B.ByteString +viaS f = C.fromChunks . pure . f . foldr S.append S.empty . C.toChunks + +stripS ::S.ByteString -> S.ByteString +stripS = S8.dropWhile isSpace . fst . S8.spanEnd isSpace + +stripC ::B.ByteString -> B.ByteString +stripC = viaS stripS + +strip ::String -> String +strip = S8.unpack . stripS . S8.pack + +split :: Char -> String -> [String] +split c = map S8.unpack . S8.split c . S8.pack + +mkF :: (MboxMessage B.ByteString -> a) -> ReaderMsg a +mkF f = asks (f . snd) + +mboxMsgSenderF, mboxMsgTimeF, mboxFromF, mboxMsgFileF, mboxMsgOffsetF, + mboxMsgF, mboxMsgBodyF, messageIDF, subjectF, {-TMP-NO-MIME mimeTypeF,-} emailShown, + oneLinerF :: FmtComb + +mboxMsgTimeF = mkF _mboxMsgTime +mboxMsgSenderF = mkF _mboxMsgSender +mboxMsgFileF = mkF $ C.pack . _mboxMsgFile +mboxMsgOffsetF = mkF $ showC . _mboxMsgOffset +mboxMsgF = mkF $ flip C.snoc '\n' . showMboxMessage +mboxMsgBodyF = mkF _mboxMsgBody +emailShown = showC . fst <$> ask +mboxFromF + = mconcat [pure "From ", mboxMsgSenderF, pure " ", mboxMsgTimeF] +messageIDF + = C.pack . fromMaybe "" + . (>>= unquote) . messageId . fst <$> ask +subjectF + = C.pack . fromMaybe "" . messageSubject . fst <$> ask +{- TMP-NO-MIME +mimeTypeF + = C.pack . showMIMEType . mimeType . mime_val_type + . get emailContent . fst <$> ask +-} +oneLinerF + = mconcat $ intersperse (pure " | ") + [ align 40 $ ellipse 40 $ subjectF + , {- TMP-NO-MIME align 15 $ mimeTypeF,-} messageIDF ] + +align :: Int -> FmtMod +align n x = B.take (fi n) <$> (x `mappend` pure (C.repeat ' ')) + +ellipse :: Int -> FmtMod +ellipse n s = (B.take (fi n) <$> s) `mappend` pure "..." + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +size, md5 :: FmtMod +size = fmap (showC . C.length) +md5 = fmap (showC . MD5.md5) + +fmtCombs :: [(String, (FmtComb, String))] +fmtCombs = [ ("one", (oneLinerF , "One line per email with: subject, mimetype and message ID (default)")) + , ("subj", (subjectF , "Subject")) + , ("mboxmsgsender", (mboxMsgSenderF , "Mbox Sender")) + , ("mboxmsgtime", (mboxMsgTimeF , "Mbox Msg Time")) + , ("mboxmsgfile", (mboxMsgFileF , "Mbox Msg File")) + , ("offset", (mboxMsgOffsetF , "Mbox Offset")) + , ("mboxmsg", (mboxMsgF , "Mbox Msg")) + , ("mboxmsgbody", (mboxMsgBodyF , "Mbox Msg Body")) + -- TMP-NO-MIME , ("mimetype", (mimeTypeF , "MIME type")) + , ("fromline", (mboxFromF , "Mbox From Line [as 'From %(mboxmsgsender) %(mboxmsgtime)']")) + , ("mid", (messageIDF , "Message ID")) + ] + +fmtMods :: [(String, (FmtMod, String))] +fmtMods = [ ("size", (size, "Commpute the size of the input")) + , ("md5", (md5, "Hash the input with MD5")) + , ("strip", (fmap stripC, "Strip leading and trailling spaces")) + ] + +intFmtMods :: [(String, ((Int -> FmtMod), String))] +intFmtMods = [ ("ellipse", (ellipse, "Truncate at N and put an ellipse")) + , ("align", (align, "Fill upto N with spaces")) + , ("take", (fmap . C.take . fi, "Take the N firsts")) + , ("drop", (fmap . C.take . fi, "Drop the N firsts")) + ] + +mayEvalStr :: String -> Maybe String +mayEvalStr = mayRead . ('\"' :) . foldr escapeDQuote "\"" + where escapeDQuote '"' = ('\\':).('"':) + escapeDQuote c = (c:) + +mayReadIntFmtMod :: String -> Maybe FmtMod +mayReadIntFmtMod s = fst <$> lookup s1 intFmtMods <*> mayRead s2 + where (s1, s2) = break isSpace s + +mayReadFmtMod :: String -> Maybe FmtMod +mayReadFmtMod s = (fst <$> lookup s fmtMods) `mplus` mayReadIntFmtMod s + +mayReadFmtComb :: String -> Maybe FmtComb +mayReadFmtComb s = case reverse (split '.' s) of + [] -> Nothing + lst : xs -> do cmb <- fst <$> lookup lst fmtCombs + mods <- mapM (mayReadFmtMod . strip) (reverse xs) + return $ foldr (.) id mods cmb + +mayReadShowFmts :: String -> Maybe FmtComb +mayReadShowFmts = f + where f [] = Just mempty + f ('%':'(':s) = let (s1,s2) = break (==')') s in + mappend <$> (mayReadFmtComb s1) <*> f (drop 1 s2) + f s = let (s1,s2) = break (=='%') s in + mappend <$> (pure . C.pack <$> mayEvalStr s1) <*> f s2 + +renderFmtComb :: FmtComb -> Message -> B.ByteString +renderFmtComb = flip evalReaderMsg diff --git a/mbox-tools.cabal b/mbox-tools.cabal --- a/mbox-tools.cabal +++ b/mbox-tools.cabal @@ -1,6 +1,6 @@ Name: mbox-tools Cabal-Version: >=1.8 -Version: 0.2.0.2 +Version: 0.2.0.3 License: BSD3 License-File: LICENSE Copyright: (c) Nicolas Pouillard @@ -49,21 +49,25 @@ Build-depends: base(>=3 && <5), bytestring, codec-mbox, parsec, hsemail, pureMD5, fclabels>=1.0, mtl main-is: mbox-list.hs + Other-modules: Email, FmtComb, EmailFmt ghc-options: -Wall executable mbox-pick Build-depends: base(>=3 && <5), bytestring, codec-mbox, parsec, hsemail, pureMD5, fclabels, mtl main-is: mbox-pick.hs + Other-modules: Email, FmtComb, EmailFmt ghc-options: -Wall executable mbox-partition Build-depends: base(>=3 && <5), bytestring, codec-mbox, parsec, hsemail, pureMD5, fclabels, mtl, containers main-is: mbox-partition.hs + Other-modules: Email ghc-options: -Wall executable mbox-grep Build-depends: base(>=3 && <5), bytestring, codec-mbox, parsec, hsemail, pureMD5, fclabels, mtl main-is: mbox-grep.hs + Other-modules: Email ghc-options: -Wall if flag(use_hutt) build-depends: hutt>=0.1