mbox-tools 0.2.0.2 → 0.2.0.3
raw patch · 4 files changed
+396/−1 lines, 4 files
Files
- Email.hs +145/−0
- EmailFmt.hs +74/−0
- FmtComb.hs +172/−0
- mbox-tools.cabal +5/−1
+ Email.hs view
@@ -0,0 +1,145 @@+--------------------------------------------------------------------+-- |+-- Module : Email+-- Copyright : (c) Nicolas Pouillard 2008, 2009, 2010, 2011+-- License : BSD3+--+-- Maintainer: Nicolas Pouillard <nicolas.pouillard@gmail.com>+-- 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 "<string>" . fixCrlfS . myCunpack+ -}++readFields :: B.ByteString -> [Field]+readFields input =+ either err id . parse fields "<string>" . fixCrlfS . myCunpack $ input+ where err e = error $ "Error in the following message <<EOS\n" ++ myCunpack input ++ "\nEOS\n\n" ++ show e++-- | Takes a message and reads only the fields part of it.+readFieldsOnly :: B.ByteString -> [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 "<string>" . 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
+ EmailFmt.hs view
@@ -0,0 +1,74 @@+--------------------------------------------------------------------+-- |+-- Module : EmailFmt+-- Copyright : (c) Nicolas Pouillard 2010, 2011+-- License : BSD3+--+-- Maintainer: Nicolas Pouillard <nicolas.pouillard@gmail.com>+-- 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'"+ ," | ( '%(' (<fct> '.')* <name> ')' | <string> )*"+ ," name ::="] +++ map ((" | '" ++) . (++ "'") . fst) fmtCombs +++ [" fct ::="] +++ map ((" | '" ++) . (++ "'") . fst) fmtMods +++ map ((" | '" ++) . (++ "' <int>") . 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)+
+ FmtComb.hs view
@@ -0,0 +1,172 @@+--------------------------------------------------------------------+-- |+-- Module : FmtComb+-- Copyright : (c) Nicolas Pouillard 2010, 2011+-- License : BSD3+--+-- Maintainer: Nicolas Pouillard <nicolas.pouillard@gmail.com>+-- 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 "<NO-VALID-MESSAGE-ID>"+ . (>>= unquote) . messageId . fst <$> ask+subjectF+ = C.pack . fromMaybe "<NO-VALID-SUBJECT>" . 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
mbox-tools.cabal view
@@ -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