diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2008, 2009, 2010, 2011 Nicolas Pouillard +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holders nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/MboxTools.hs b/MboxTools.hs new file mode 100644 --- /dev/null +++ b/MboxTools.hs @@ -0,0 +1,1 @@ +module MboxTools where diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/mbox-average-size.hs b/mbox-average-size.hs new file mode 100644 --- /dev/null +++ b/mbox-average-size.hs @@ -0,0 +1,20 @@ +import Codec.Mbox (Mbox(..), MboxMessage(..), parseMbox) +import Control.Applicative ((<$>)) +import Data.List (foldl') +import qualified Data.ByteString.Lazy as B + +data P a = P !a !Int + +-- spec: average xs = sum xs / fromIntegral (length xs) +-- still slow (too lazy tuple): average = uncurry (/) . foldl' f (0,0) where f (a,b) x = (a+x,b+1) +average :: Fractional a => [a] -> a +average xs = s / fromIntegral l + where (P s l) = foldl' f (P 0 0) xs + f (P a b) x = P (a + x) (b + 1) + +mboxAverageSize :: Mbox B.ByteString -> Double +mboxAverageSize = average . map (fromIntegral . B.length . get mboxMsgBody) . mboxMessages + +main :: IO () +main = do putStrLn "Reading from stdin..." + print =<< (mboxAverageSize . parseMbox) <$> B.getContents diff --git a/mbox-counting.hs b/mbox-counting.hs new file mode 100644 --- /dev/null +++ b/mbox-counting.hs @@ -0,0 +1,7 @@ +import Codec.Mbox (mboxMessages,parseMbox) +import qualified Data.ByteString.Lazy as B +import System.IO (hPutStrLn, stderr) + +main :: IO () +main = do hPutStrLn stderr "Reading from stdin..." + (print . length . mboxMessages . parseMbox) =<< B.getContents diff --git a/mbox-from-files.hs b/mbox-from-files.hs new file mode 100644 --- /dev/null +++ b/mbox-from-files.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators #-} +-------------------------------------------------------------------- +-- | +-- Executable : mbox-from-files +-- Copyright : (c) Nicolas Pouillard 2010, 2011 +-- License : BSD3 +-- +-- Maintainer: Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +import Prelude hiding (mod) +import Control.Monad (join) +import Codec.Mbox (Mbox(..),MboxMessage(..),showMbox) +import System.Environment (getArgs) +import System.Console.GetOpt +import Data.Label +import qualified Data.ByteString.Lazy.Char8 as B + +data Settings = Settings { _help :: Bool } + +$(mkLabels [''Settings]) + +type Flag = Settings -> Settings + +msgFromFile :: FilePath -> IO (MboxMessage B.ByteString) +msgFromFile fp = + do contents <- B.readFile fp + return $ MboxMessage { _mboxMsgSender = B.pack "XXX" + , _mboxMsgTime = B.pack "Thu Jan 01 01:00:00 +0100 1970" + , _mboxMsgBody = contents + , _mboxMsgFile = fp + , _mboxMsgOffset = undefined } + +mboxFromFiles :: Settings -> [FilePath] -> IO () +mboxFromFiles _ = + join . fmap (B.putStr . showMbox . Mbox) + . mapM msgFromFile + +defaultSettings :: Settings +defaultSettings = Settings { _help = False } + +usage :: String -> a +usage msg = error $ unlines ls + where header = "Usage: mbox-from-files [OPTION] *" + ls = msg : usageInfo header options : + ["If no files are given as argument, a list of" + ,"file names is read from the standard input."] + +options :: [OptDescr Flag] +options = + [ Option "?" ["help"] (NoArg (set help True)) "Show this help message" + ] + +main :: IO () +main = do + args <- getArgs + let (flags, nonopts, errs) = getOpt Permute options args + let opts = foldr ($) defaultSettings flags + if get help opts + then usage "" + else + case (nonopts, errs) of + ([], []) -> mboxFromFiles opts . lines =<< getContents + (files, []) -> mboxFromFiles opts files + (_, _) -> usage (concat errs) + diff --git a/mbox-grep.hs b/mbox-grep.hs new file mode 100644 --- /dev/null +++ b/mbox-grep.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators #-} +-------------------------------------------------------------------- +-- | +-- Executable : mbox-grep +-- Copyright : (c) Nicolas Pouillard 2008, 2009, 2010, 2011 +-- License : BSD3 +-- +-- Maintainer: Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +import Codec.Mbox (Mbox(..), MboxMessage(..), Direction(..), parseMboxFiles, opposite) +import Email (Email(..),ShowFormat(..),fmtOpt,defaultShowFormat, + readEmail,putEmails,showFormatsDoc,stringOfField) +import System.Environment (getArgs) +import Text.ParserCombinators.Parsec (parse) +import Hutt.Query (evalQueryMsg,parseQuery) +import Hutt.Types(Msg(..),Dsc(..),MsgId(..),DscId(..),Query(..)) +import Data.Tree (Tree(..)) +import Data.Label +import Control.Arrow +import System.Console.GetOpt + +data Settings = Settings { _fmt :: ShowFormat + , _dir :: Direction + , _help :: Bool + } +$(mkLabels [''Settings]) +type Flag = Settings -> Settings + +grepMbox :: Settings -> String -> [String] -> IO () +grepMbox opts queryString = (mapM_ f =<<) . parseMboxFiles (get dir opts) + where query = either (error "malformed query") id $ parse parseQuery "" queryString + f = putEmails (get fmt opts) + . filter (emailMatchQuery query . fst) + . map ((readEmail . get mboxMsgBody) &&& id) . mboxMessages + +emailMatchQuery :: Query -> Email -> Bool +emailMatchQuery query email = evalQueryMsg (msg, dsc) query + where msg = Msg { msgHeader = map stringOfField $ emailFields email + --, msgBody = rawEmail email + , msgContent = rawEmail email -- emailContent email + , msgId = MsgId 0 + , msgLabels = [] + , msgAddress = undefined + , msgParent = Nothing + , msgReferences = [] } + dsc = Dsc { dscId = DscId 0 + , dscMsgs = Node () [] + , dscLabels = [] } + +main :: IO () +main = do + args <- getArgs + let (flags, nonopts, errs) = getOpt Permute options args + let opts = foldr ($) defaultSettings flags + if get help opts + then usage "" + else + case (nonopts, errs) of + (queryString : files, []) -> grepMbox opts queryString files + (_, []) -> usage "Too few arguments" + _ -> usage (concat errs) + +defaultSettings :: Settings +defaultSettings = Settings { _fmt = defaultShowFormat + , _dir = Forward + , _help = False + } + +usage :: String -> a +usage msg = error $ unlines [msg, usageInfo header options, showFormatsDoc] + where header = "Usage: mbox-grep [OPTIONS] *" + +options :: [OptDescr Flag] +options = + [ fmtOpt usage (set fmt) + , Option "r" ["reverse"] (NoArg (modify dir opposite)) "Reverse the mbox order (latest firsts)" + , Option "?" ["help"] (NoArg (set help True)) "Show this help message" + ] + diff --git a/mbox-iter.hs b/mbox-iter.hs new file mode 100644 --- /dev/null +++ b/mbox-iter.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators, ScopedTypeVariables #-} +-------------------------------------------------------------------- +-- | +-- Executable : mbox-iter +-- Copyright : (c) Nicolas Pouillard 2009, 2011 +-- License : BSD3 +-- +-- Maintainer: Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +-- import Control.Arrow +import Control.Exception +import Codec.Mbox (Mbox(..),Direction(..),parseMboxFiles,opposite,showMboxMessage) +import System.Environment (getArgs) +import System.Console.GetOpt +import System.Exit +import System.IO +import qualified System.Process as P +import qualified Data.ByteString.Lazy as L +import Data.Label + +data Settings = Settings { _dir :: Direction + , _help :: Bool + } +$(mkLabels [''Settings]) + +type Flag = Settings -> Settings + +systemWithStdin :: String -> L.ByteString -> IO ExitCode +systemWithStdin shellCmd input = do + (Just stdinHdl, _, _, pHdl) <- + P.createProcess (P.shell shellCmd){ P.std_in = P.CreatePipe } + handle (\(_ :: IOException) -> return ()) $ do + L.hPut stdinHdl input + hClose stdinHdl + P.waitForProcess pHdl + +iterMbox :: Settings -> String -> [String] -> IO () +iterMbox opts cmd mboxfiles = + mapM_ (mapM_ (systemWithStdin cmd . showMboxMessage) . mboxMessages) + =<< parseMboxFiles (get dir opts) mboxfiles + +defaultSettings :: Settings +defaultSettings = Settings { _dir = Forward + , _help = False + } + +usage :: String -> a +usage msg = error $ unlines [msg, usageInfo header options] + where header = "Usage: mbox-iter [OPTION] *" + +options :: [OptDescr Flag] +options = + [ Option "r" ["reverse"] (NoArg (modify dir opposite)) "Reverse the mbox order (latest firsts)" + , Option "?" ["help"] (NoArg (set help True)) "Show this help message" + ] + +main :: IO () +main = do + args <- getArgs + let (flags, nonopts, errs) = getOpt Permute options args + let opts = foldr ($) defaultSettings flags + if get help opts + then usage "" + else + case (nonopts, errs) of + (cmd : mboxfiles, []) -> iterMbox opts cmd mboxfiles + (_, _) -> usage (concat errs) + diff --git a/mbox-list.hs b/mbox-list.hs new file mode 100644 --- /dev/null +++ b/mbox-list.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators #-} +-------------------------------------------------------------------- +-- | +-- Executable : mbox-list +-- Copyright : (c) Nicolas Pouillard 2008, 2009, 2011 +-- License : BSD3 +-- +-- Maintainer: Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +import Prelude +import Control.Arrow +import Codec.Mbox (Mbox(..),Direction(..),parseMboxFiles,mboxMsgBody,opposite) +import Email (readEmail) +import EmailFmt (putEmails,ShowFormat(..),fmtOpt,defaultShowFormat,showFormatsDoc) +import System.Environment (getArgs) +import System.Console.GetOpt +import Data.Label + +data Settings = Settings { _fmt :: ShowFormat + , _dir :: Direction + , _takeOpt :: Maybe Int + , _dropOpt :: Maybe Int + , _help :: Bool + } +$(mkLabels [''Settings]) + +type Flag = Settings -> Settings + +listMbox :: Settings -> [String] -> IO () +listMbox opts mboxfiles = + mapM_ (putEmails (get fmt opts) . + map ((readEmail . get mboxMsgBody) &&& id) . + maybe id take (get takeOpt opts) . + maybe id drop (get dropOpt opts) . + mboxMessages) + =<< parseMboxFiles (get dir opts) mboxfiles + +defaultSettings :: Settings +defaultSettings = Settings { _fmt = defaultShowFormat + , _dir = Forward + , _takeOpt = Nothing + , _dropOpt = Nothing + , _help = False + } + +usage :: String -> a +usage msg = error $ unlines [msg, usageInfo header options, showFormatsDoc] + where header = "Usage: mbox-list [OPTION] *" + +maybeIntArg :: (Settings :-> Maybe Int) -> ArgDescr (Settings -> Settings) +maybeIntArg l = ReqArg (set l . Just . read) "NUM" + +-- Since +-- ∀ k1 k2 Positives, take k1 . drop k2 == drop k2 . take (k2 + k1) +-- one fix an ordering: drop then take. +options :: [OptDescr Flag] +options = + [ fmtOpt usage (set fmt) + , Option "r" ["reverse"] (NoArg (modify dir opposite)) "Reverse the mbox order (latest firsts)" + , Option "d" ["drop"] (maybeIntArg dropOpt) "Drop the NUM firsts" + , Option "t" ["take"] (maybeIntArg takeOpt) "Take the NUM firsts (happens after --drop)" + , Option "?" ["help"] (NoArg (set help True)) "Show this help message" + ] + +main :: IO () +main = do + args <- getArgs + let (flags, nonopts, errs) = getOpt Permute options args + let opts = foldr ($) defaultSettings flags + if get help opts + then usage "" + else + case (nonopts, errs) of + (mboxfiles, []) -> listMbox opts mboxfiles + (_, _) -> usage (concat errs) + diff --git a/mbox-partition.hs b/mbox-partition.hs new file mode 100644 --- /dev/null +++ b/mbox-partition.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators #-} +-------------------------------------------------------------------- +-- | +-- Executable : mbox-partition +-- Copyright : (c) Nicolas Pouillard 2008, 2009, 2011 +-- License : BSD3 +-- +-- Maintainer: Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +import Control.Applicative +import Codec.Mbox (Mbox(..),Direction(..),parseMboxFile,mboxMsgBody,showMboxMessage) +import Email (Email(..),emailFields,readEmail) +import Text.ParserCombinators.Parsec.Rfc2822 (Field(MessageID)) +import Data.Label +import Data.Maybe (listToMaybe, fromMaybe) +import Data.Set (fromList, member) +import qualified Data.ByteString.Lazy.Char8 as C +import System.Environment (getArgs) +import System.Console.GetOpt +import System.IO (Handle, IOMode(AppendMode), stderr, openFile, hPutStr, hFlush, hClose) + +progressStr :: String -> IO () +progressStr s = hPutStr stderr ('\r':s) >> hFlush stderr + +progress_ :: [IO a] -> IO () +progress_ = (>> progressStr "Finished\n") . sequence_ . zipWith (>>) (map (progressStr . show) [(1::Int)..]) + +-- should be in ByteString +hPutStrLnC :: Handle -> C.ByteString -> IO () +hPutStrLnC h s = C.hPut h s >> C.hPut h (C.pack "\n") + +data Settings = Settings { _help :: Bool + , _msgids :: String + , _inside :: String + , _outside :: String + } +$(mkLabels [''Settings]) +type Flag = Settings -> Settings + +partitionMbox :: Settings -> [String] -> IO () +partitionMbox opts mboxfiles = do + msgids' <- (fromList . C.lines) <$> C.readFile (get msgids opts) + let predicate = fromMaybe False . fmap (`member` msgids') . emailMsgId . readEmail . get mboxMsgBody + hinside <- openFile (get inside opts) AppendMode + houtside <- openFile (get outside opts) AppendMode + let onFile fp = + progress_ . map (\m -> hPutStrLnC (if predicate m then hinside else houtside) (showMboxMessage m)) + . mboxMessages + =<< parseMboxFile Forward fp + mapM_ onFile mboxfiles + mapM_ hClose [hinside, houtside] + +emailMsgId :: Email -> Maybe C.ByteString +emailMsgId m = listToMaybe [ removeAngles $ C.pack i | MessageID i <- get emailFields m ] + +removeAngles :: C.ByteString -> C.ByteString +removeAngles = C.takeWhile (/='>') . C.dropWhile (=='<') + +defaultSettings :: Settings +defaultSettings = Settings { _help = False + , _msgids = "" + , _inside = "" + , _outside = "" } + +usage :: String -> a +usage msg = error (msg ++ "\n" ++ usageInfo header options) + where header = "Usage: mbox-partition [OPTION...] *" + +options :: [OptDescr Flag] +options = + [ Option "m" ["msgids"] (ReqArg (set msgids) "FILE") "A file with message-IDs" + , Option "i" ["inside"] (ReqArg (set inside) "FILE") "Will receive messages referenced by the 'msgids' file" + , Option "o" ["outside"] (ReqArg (set outside) "FILE") "Will receive messages *NOT* referenced by the 'msgids' file" + , Option "?" ["help"] (NoArg (set help True)) "Show this help message" + ] + +main :: IO () +main = do + args <- getArgs + let (flags, nonopts, errs) = getOpt Permute options args + let opts = foldr ($) defaultSettings flags + case (nonopts, errs) of + _ | get help opts -> usage "" + (_, _:_) -> usage (concat errs) + ([], _) -> usage "Too few arguments (mbox-file missing)" + (mboxfiles, _) -> partitionMbox opts mboxfiles + diff --git a/mbox-pick.hs b/mbox-pick.hs new file mode 100644 --- /dev/null +++ b/mbox-pick.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators #-} +-------------------------------------------------------------------- +-- | +-- Executable : mbox-pick +-- Copyright : (c) Nicolas Pouillard 2008, 2009, 2011 +-- License : BSD3 +-- +-- Maintainer: Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +import Control.Arrow +import Control.Applicative +import Data.Label +import Data.Maybe (fromMaybe, listToMaybe) +import qualified Data.ByteString.Lazy.Char8 as C +import Codec.Mbox (mboxMsgBody,parseOneMboxMessage) +import Email (readEmail) +import EmailFmt (putEmails,ShowFormat(..),fmtOpt,defaultShowFormat,showFormatsDoc) +import System.Environment (getArgs) +import System.Console.GetOpt +import System.IO (IOMode(..), stdin, openFile, hClose) + +mayRead :: Read a => String -> Maybe a +mayRead s = case reads s of + [(x, "")] -> Just x + _ -> Nothing + +parseSeq :: C.ByteString -> Maybe [Integer] +parseSeq = mapM (mayRead . C.unpack) . C.split ',' + +data Settings = Settings { _fmt :: ShowFormat + , _help :: Bool + } +$(mkLabels [''Settings]) + +type Flag = Settings -> Settings + +pickMbox :: Settings -> String -> Maybe FilePath -> IO () +pickMbox opts sequ' mmbox = do + mbox <- maybe (return stdin) (`openFile` ReadMode) mmbox + sequ <- maybe (fail "badly formatted comma separated offset sequence") return $ parseSeq $ C.pack sequ' + mails <- mapM ((((readEmail . get mboxMsgBody) &&& id) <$>) . parseOneMboxMessage (fromMaybe "" mmbox) mbox) sequ + putEmails (get fmt opts) mails + hClose mbox + +defaultSettings :: Settings +defaultSettings = Settings { _fmt = defaultShowFormat + , _help = False + } + +usage :: String -> a +usage msg = error $ unlines [msg, usageInfo header options, showFormatsDoc] + where header = "Usage: mbox-pick [OPTION] ,,..., " + +options :: [OptDescr Flag] +options = + [ fmtOpt usage (set fmt) + , Option "?" ["help"] (NoArg (set help True)) "Show this help message" + ] + +main :: IO () +main = do + args <- getArgs + let (flags, nonopts, errs) = getOpt Permute options args + let opts = foldr ($) defaultSettings flags + if get help opts + then usage "" + else + case (nonopts, errs) of + ([], []) -> usage "Too few arguments" + (_:_:_:_, []) -> usage "Too many arguments" + (sequ : mbox, []) -> pickMbox opts sequ $ listToMaybe mbox + (_, _) -> usage (concat errs) + diff --git a/mbox-quoting.hs b/mbox-quoting.hs new file mode 100644 --- /dev/null +++ b/mbox-quoting.hs @@ -0,0 +1,13 @@ +import Codec.Mbox (fromQuoting) +import qualified Data.ByteString.Lazy.Char8 as C (getContents,putStr) +import Control.Applicative ((<$>)) +import System.Environment (getArgs) +import System.IO (hPutStrLn,stderr) + +main :: IO () +main = do + args <- getArgs + case args of + ["quot"] -> C.putStr =<< fromQuoting (+1) <$> C.getContents + ["unquot"] -> C.putStr =<< fromQuoting (+(-1)) <$> C.getContents + _ -> hPutStrLn stderr "Usage: mbox-quoting {quot|unquot}" diff --git a/mbox-tools.cabal b/mbox-tools.cabal new file mode 100644 --- /dev/null +++ b/mbox-tools.cabal @@ -0,0 +1,76 @@ +Name: mbox-tools +Cabal-Version: >=1.8 +Version: 0.2.0.0 +License: BSD3 +License-File: LICENSE +Copyright: (c) Nicolas Pouillard +Author: Nicolas Pouillard +Maintainer: Nicolas Pouillard +Category: Email, Utility +Synopsis: A collection of tools to process mbox files +Description: A collection of tools to process mbox files +Homepage: https://github.com/np/mbox-tools +Stability: Experimental +Build-Type: Simple + +flag use_hutt + Default: False + -- hutt-0.1 is not released + +flag useless + Default: False + +Library + Build-depends: base(>=3 && <5), containers>=0.1, bytestring>=0.9, parsec, + transformers, monads-fd, fclabels>=1.0, pureMD5, + codec-mbox>=0.1, hsemail>=1.3.1 + -- TMP-NO-MIME, mime-bytestring + exposed-modules: MboxTools +-- TODO hsemail-1.3.1 is not released +-- mime-bytestring is not yet released + +executable mbox-counting + main-is: mbox-counting.hs + ghc-options: -Wall +executable mbox-average-size + main-is: mbox-average-size.hs + ghc-options: -Wall + if !flag(useless) + buildable: False +executable mbox-quoting + main-is: mbox-quoting.hs + ghc-options: -Wall + if !flag(useless) + buildable: False +executable redact-mbox + main-is: redact-mbox.hs + Build-depends: random + ghc-options: -Wall + if !flag(useless) + buildable: False +executable mbox-list + main-is: mbox-list.hs + ghc-options: -Wall +executable mbox-pick + main-is: mbox-pick.hs + ghc-options: -Wall +executable mbox-partition + main-is: mbox-partition.hs + ghc-options: -Wall +executable mbox-grep + main-is: mbox-grep.hs + ghc-options: -Wall + if flag(use_hutt) + build-depends: hutt>=0.1 + else + buildable: False +executable split-mbox + main-is: split-mbox.hs + ghc-options: -Wall +executable mbox-iter + main-is: mbox-iter.hs + ghc-options: -Wall + build-depends: process +executable mbox-from-files + main-is: mbox-from-files.hs + ghc-options: -Wall diff --git a/redact-mbox.hs b/redact-mbox.hs new file mode 100644 --- /dev/null +++ b/redact-mbox.hs @@ -0,0 +1,85 @@ +-------------------------------------------------------------------- +-- | +-- Executable : redact-mbox +-- Copyright : (c) Nicolas Pouillard 2008, 2009, 2011 +-- License : BSD3 +-- +-- Maintainer: Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +import Codec.Mbox (Mbox(..),MboxMessage(..),parseMbox,showMbox) +import qualified Data.ByteString.Lazy as B (ByteString,readFile,writeFile) +import qualified Data.ByteString.Lazy.Char8 as C (mapAccumL,unpack,pack) +import Data.List (mapAccumL) +import Data.Char (isDigit,isLower,isUpper) +import Control.Applicative +import Control.Monad.State +import System.Environment (getArgs) +import System.Random (getStdGen,randomRs) +import System.IO + +type RedactState a = State [Int] a + +-- BEGIN MISSING +consume :: State [a] a +consume = do (c:cs) <- get + put cs + return c + +infix !!! +(!!!) :: [a] -> Int -> a +[] !!! _ = error "!!!: empty list" +lst !!! idx = go lst idx + where go [] n = go lst n + go (x:_) 0 = x + go (_:xs) (n + 1) = go xs n + go _ _ = error "!!!: negative index" + +-- prop_nthmod (NonNegative n) (NonEmpty xs) = xs !!! n == xs !! (n `mod` length xs) + +swap :: (a,b) -> (b,a) +swap (x,y) = (y,x) + +wrapState :: (acc -> x -> (acc, y)) -> x -> State acc y +wrapState f x = State (\state -> swap (f state x)) + +unwrapState :: (x -> State acc y) -> acc -> x -> (acc, y) +unwrapState f state x = swap (runState (f x) state) +-- END MISSING + +redactChar :: Char -> RedactState Char +redactChar c | c `elem` " \t\n!@#$%^&*()[]{}/=?+-_:;|\\" = return c + | isDigit c = (digits !!!) <$> consume + | isLower c = (lowers !!!) <$> consume + | isUpper c = (uppers !!!) <$> consume + | otherwise = (alphas !!!) <$> consume + +digits, alphas, lowers, uppers :: [Char] +digits = ['0'..'9'] +lowers = ['a'..'z'] +uppers = ['A'..'Z'] +alphas = lowers ++ uppers + +redactString :: B.ByteString -> RedactState B.ByteString +redactString = wrapState $ C.mapAccumL $ unwrapState redactChar + +{- NOTE that the offset is not redacted -} +redactMboxMessage :: MboxMessage B.ByteString -> RedactState (MboxMessage B.ByteString) +redactMboxMessage (MboxMessage sender time body file offset) = + MboxMessage `fmap` redactString sender `ap` redactString time `ap` redactString body + `ap` (C.unpack `fmap` redactString (C.pack file)) `ap` return offset + +main :: IO () +main = do + args <- getArgs + ints <- randomRs (0, length digits + length alphas) <$> getStdGen + case args of + [argin,argout] -> + B.writeFile argout + =<< return . showMbox . Mbox . snd . mapAccumL (unwrapState redactMboxMessage) ints . mboxMessages . parseMbox + =<< B.readFile argin + _ -> hPutStrLn stderr "Usage: redact-mbox " + diff --git a/split-mbox.hs b/split-mbox.hs new file mode 100644 --- /dev/null +++ b/split-mbox.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE BangPatterns, ExistentialQuantification, TemplateHaskell, + TypeOperators #-} +-------------------------------------------------------------------- +-- | +-- Executable : split-mbox +-- Copyright : (c) Nicolas Pouillard 2008, 2009, 2011 +-- License : BSD3 +-- +-- Maintainer: Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +import Control.Arrow +import Codec.Mbox (Mbox(..),MboxMessage,Direction(..),msgYear,msgMonthYear,parseMboxFile,showMbox) +import qualified Data.ByteString.Lazy.Char8 as C +import Data.Label +import Data.Char (toLower) +import Data.List (groupBy) +import Data.Maybe (fromMaybe) +import System.Environment (getArgs) +import System.Console.GetOpt +import System.IO (hFlush, stdout) + +equating :: Eq b => (a -> b) -> a -> a -> Bool +equating f x y = f x == f y + +chunks :: Int -> [a] -> [[a]] +chunks _ [] = [] +chunks n xs = uncurry (:) $ second (chunks n) $ splitAt n xs + +-- Year is first +data SplitBy = Year | Month + deriving (Show, Enum) + +data Settings = Settings { _help :: Bool, _splitBy :: SplitBy } +$(mkLabels [''Settings]) +type Flag = Settings -> Settings + +splitMbox :: Eq a => (MboxMessage C.ByteString -> a) -> (MboxMessage C.ByteString -> String) -> String -> IO () +splitMbox keyMsg fmtMsg mboxfile = do + -- this 'chunks' trick is to avoid a lazyness problem + mapM_ go . concatMap (groupBy (equating keyMsg)) . chunks 1000 . mboxMessages =<< parseMboxFile Forward mboxfile + putStrLn "done." + where go ms = do let !fp = "mbox-" ++ (fmtMsg $ head ms) + putStr ("\rWriting to " ++ fp ++ "...") + hFlush stdout + C.appendFile fp . showMbox . Mbox $ ms + +splitMboxWith :: Settings -> String -> IO () +splitMboxWith settings = + case get splitBy settings of + Year -> splitMbox msgYear (show . msgYear) + Month -> splitMbox msgMonthYear (uncurry (++) . (map toLower . show *** ('-':) . show) . msgMonthYear) + +defaultSettings :: Settings +defaultSettings = Settings { _help = False, _splitBy = Year } + +usage :: String -> a +usage msg = error (msg ++ "\n" ++ usageInfo header options) + where header = "Usage: split-mbox [OPTION...] mbox-files..." + +options :: [OptDescr Flag] +options = + [ Option "?" ["help"] (NoArg (set help True)) "Show this help message" + , byOpt ] + +byOpt :: OptDescr Flag +byOpt = Option "b" ["by"] (ReqArg (set splitBy . parseBy) "ARG") desc + where parseBy = fromMaybe (usage "Bad argument") . (`lookup` args) + args = map ((map toLower . show) &&& id) [ Year .. ] + desc = "Split by " ++ show (map fst args) + +main :: IO () +main = do + args <- getArgs + let (flags, nonopts, errs) = getOpt Permute options args + let opts = foldr ($) defaultSettings flags + if get help opts + then usage "" + else + case (nonopts, errs) of + ([], []) -> usage "Too few arguments" + (mboxfiles, []) -> mapM_ (splitMboxWith opts) mboxfiles + (_, _) -> usage (concat errs) +