carboncopy (empty) → 0.1
raw patch · 11 files changed
+527/−0 lines, 11 filesdep +IfElsedep +MissingHdep +basesetup-changed
Dependencies added: IfElse, MissingH, base, bytestring, filepath, haskell98
Files
- CarbonCopy/Configuration.hs +63/−0
- CarbonCopy/EmailStorage.hs +30/−0
- CarbonCopy/HeadersStorage.hs +37/−0
- CarbonCopy/MailHeaders.hs +35/−0
- CarbonCopy/StorageInit.hs +30/−0
- CarbonCopy/ThreadBuilder.hs +80/−0
- LICENSE +30/−0
- Main.hs +101/−0
- README.txt +47/−0
- Setup.hs +2/−0
- carboncopy.cabal +72/−0
+ CarbonCopy/Configuration.hs view
@@ -0,0 +1,63 @@+module CarbonCopy.Configuration (+ Configuration, + loadConfiguration, + defaultConfiguration,+ getPath, + getEmail) where++import Data.ByteString.Char8 as BStr+import Text.ParserCombinators.ReadP as R+import Data.Char+import Data.Maybe+import Data.List++import Prelude as P++data Option = Path String | Email String | Unparsed String++data Configuration = Configuration [Option]+++defaultConfiguration :: String -> Configuration+defaultConfiguration email = Configuration [Path ".ccheader", Email email]++loadConfiguration :: ByteString -> Configuration+loadConfiguration content = Configuration ( P.foldl (parseLine) [] $ BStr.lines content )+ where + parseLine :: [Option] -> ByteString -> [Option]+ parseLine acc line = case parsedLine of+ [(nv@(name,value),_)] -> handleNv nv+ [(nv@(name,value),_),_] -> handleNv nv+ unparsed -> (Unparsed unpackedLine):acc+ where handleNv (name,value) =+ case name of+ "cc_header_file" -> (Path value):acc+ "originator_email" -> (Email value):acc+ _ -> acc+ unpackedLine = BStr.unpack line+ parsedLine = readP_to_S extractNameValue unpackedLine++extractNameValue :: ReadP (String, String)+extractNameValue = do+ name <- munch ( not . (\c -> isSpace c || c `P.elem` "#="))+ skipSpaces+ char '='+ skipSpaces+ value <- munch (\_ -> True)+ skipSpaces+ return (name, value)+++getPath :: Configuration -> Maybe String+getPath (Configuration xs) = listToMaybe [value | Path value <- xs]++getEmail :: Configuration -> Maybe String+getEmail (Configuration xs) = listToMaybe [email | Email email <- xs]++instance Show Configuration where+ show (Configuration xs) = P.foldl ( flip ((++) . (++ "\n") . show) ) "" xs++instance Show Option where+ show (Email value) = "email => " ++ value+ show (Path value) = "path => " ++ value+ show (Unparsed line) = "unparsed => " ++ line
+ CarbonCopy/EmailStorage.hs view
@@ -0,0 +1,30 @@+module CarbonCopy.EmailStorage (EmailHandler, visitEmailsRecursively) where++import Control.Monad+import System.IO.HVFS+import System.FilePath.Posix+import Data.ByteString.Char8 as BStr++import Prelude as P++type EmailHandler = ByteString -> IO ()++(?:) :: IO (Bool) -> ( IO (), IO () ) -> IO ()+(?:) cond (actL,actR) = cond >>= \condExp -> if condExp then actL else actR++(?&) :: IO (Bool) -> IO () -> IO ()+(?&) cond act = cond ?: ( act, return () )++visitEmailsRecursively :: FilePath -> EmailHandler -> IO ()+visitEmailsRecursively dir emailHandler =+ vGetDirectoryContents SystemFS dir >>= mapM_ processDirectory . P.filter (not . flip P.elem [".",".."] )+ where + processDirectory _path = fileExists ?: + ( BStr.readFile filePath >>= emailHandler, + dirExists ?& visitEmailsRecursively newDir emailHandler+ )+ where+ filePath = dir </> _path+ fileExists = vDoesFileExist SystemFS filePath+ dirExists = vDoesDirectoryExist SystemFS filePath+ newDir = addTrailingPathSeparator filePath
+ CarbonCopy/HeadersStorage.hs view
@@ -0,0 +1,37 @@+{-# OPTIONS_GHC -XTypeSynonymInstances -XMultiParamTypeClasses #-}+module CarbonCopy.HeadersStorage (Storage, fileStorage, hdrAdd, hdrExists ) where++import Data.ByteString.Lazy.Char8 as BStr+import CarbonCopy.MailHeaders+import System.IO+import Prelude as P++crlf = BStr.pack "\n"++data Storage headerT = HeadersStorage {+ exists :: headerT -> IO (Bool),+ add :: headerT -> IO ()+}++hdrExists :: Storage headerT -> headerT -> IO (Bool)+hdrExists = exists++hdrAdd :: Storage headerT -> headerT -> IO ()+hdrAdd = add++fileStorage :: FilePath -> Storage StrHeader+fileStorage path = HeadersStorage {+ exists = existsInFile path ,+ add = \hdr -> do + BStr.appendFile path . BStr.pack . value $ hdr + BStr.appendFile path crlf+}++existsInFile :: FilePath -> StrHeader -> IO (Bool)+existsInFile path hdr = do + handle <- openFile path ReadMode + found <- fmap (P.elem hdrValue . BStr.lines) $ BStr.hGetContents handle+ found `seq` hClose handle+ return found+ where+ hdrValue = BStr.pack . value $ hdr
+ CarbonCopy/MailHeaders.hs view
@@ -0,0 +1,35 @@+{-# OPTIONS_GHC -XTypeSynonymInstances #-}+module CarbonCopy.MailHeaders (+ Header(..),+ StrHeader,+ HeaderMatcher,+ extractHeaders,+ msg_id_hdr,+ from_hdr,+ in_reply_to_hdr+ ) where++import Prelude as P+import Data.Char+import Data.ByteString.Char8 as BStr hiding (concatMap, takeWhile)+import Text.ParserCombinators.ReadP as R++data (Eq keyT) => Header keyT valueT = Header { name :: keyT, value :: valueT } deriving Eq++type StrHeader = Header String String++instance Show StrHeader where+ show (Header name value) = show name ++ ":" ++ show value++type HeaderMatcher = ReadP StrHeader++msg_id_hdr = "message-id"+in_reply_to_hdr = "in-reply-to"+from_hdr = "from"++extractHeaders :: ByteString -> HeaderMatcher -> [StrHeader]+extractHeaders src matcher = concatMap parse . takeWhile ( /= BStr.empty) $ lines+ where+ lines = BStr.lines src+ parse l = P.map fst $ readP_to_S matcher line+ where line = BStr.unpack ( BStr.map (toLower) l ) ++ "\n"
+ CarbonCopy/StorageInit.hs view
@@ -0,0 +1,30 @@+module CarbonCopy.StorageInit (+ storageInit+ ) where++import Control.Monad.IfElse+import Data.Maybe+import CarbonCopy.EmailStorage+import CarbonCopy.MailHeaders+import CarbonCopy.HeadersStorage+import CarbonCopy.ThreadBuilder++storageInit :: String -> FilePath -> Storage StrHeader -> IO ()+storageInit email rootDir storage = visitEmailsRecursively rootDir ( processHeader email storage )+++processHeader :: String -> Storage StrHeader -> EmailHandler+processHeader email storage content = processHeader' chain+ where+ (chain, hdrsMatchFound) = matchFromHeader content email+ processHeader' (Just (Chain {current=fromMsgId, previous=inReplyTo})) = processHeader'' hdrsMatchFound+ where+ processHeader'' True = unlessM (storage `hdrExists` fromMsgId) $ storage `hdrAdd` fromMsgId+ processHeader'' False = whenM (storage `hdrExists` inReplyTo) $ + unlessM (storage `hdrExists` fromMsgId) $ + storage `hdrAdd` fromMsgId+ processHeader' (Just (Root {current=fromMsgId})) = processHeader'' hdrsMatchFound+ where+ processHeader'' True = unlessM (storage `hdrExists` fromMsgId) $ storage `hdrAdd` fromMsgId+ processHeader'' False = return ()+ processHeader' _ = return ()
+ CarbonCopy/ThreadBuilder.hs view
@@ -0,0 +1,80 @@+{-# OPTIONS_GHC -XTypeSynonymInstances -XMultiParamTypeClasses #-}+module CarbonCopy.ThreadBuilder (+ headerVal,+ saveMatchingChain,+ Chain(..),+ prepareChain,+ matchFromHeader,+ MsgidChain) where++import Control.Monad+import CarbonCopy.MailHeaders+import CarbonCopy.HeadersStorage+import Data.Maybe+import Data.ByteString.Char8 as BStr+import Text.ParserCombinators.ReadP as R+import Data.List as L+import Prelude as P++data Chain keyT valueT = Chain { current, previous :: Header keyT valueT} | Root { current :: Header keyT valueT }++type MsgidChain = Chain String String+++saveMatchingChain :: Storage (Header keyT valueT) -> Chain keyT valueT -> IO (Bool)+saveMatchingChain storage + ( Chain { current=myCurrent, previous=myPrevious } ) = do+ prevHdrExists <- storage `hdrExists` myPrevious+ currHdrExists <- storage `hdrExists` myCurrent+ when (prevHdrExists && not currHdrExists) $ storage `hdrAdd` myCurrent+ return ( prevHdrExists || currHdrExists )+saveMatchingChain storage _ = return False++findHeaderByName :: String -> [StrHeader] -> Maybe (StrHeader)+findHeaderByName hdrName = L.find ( (hdrName ==) . name )++prepareChain :: [StrHeader] -> Maybe (MsgidChain)+prepareChain hdrs = processNextHeader $ findHeaderByName in_reply_to_hdr hdrs+ where + processNextHeader (Just inReplyToHdr) = do+ msgIdHdr <- findHeaderByName msg_id_hdr hdrs+ Just (Chain msgIdHdr inReplyToHdr)+ processNextHeader Nothing = do+ msgIdHdr <- findHeaderByName msg_id_hdr hdrs+ Just (Root msgIdHdr)++matchFromHeader :: ByteString -> String -> ( Maybe MsgidChain, Bool )+matchFromHeader content email = ( chain, hdrsMatchFound )+ where + headers = visitHeader content+ hdrsMatchFound = or $ P.map hdrMatch headers+ chain = prepareChain headers+ hdrMatch (Header name value) = name == from_hdr && email `L.isInfixOf` value++visitHeader :: ByteString -> [StrHeader]+visitHeader = flip extractHeaders ( + headerValue from_hdr +++ + headerVal msg_id_hdr +++ + headerVal in_reply_to_hdr + )++headerValue :: String -> ReadP StrHeader+headerValue hdrName = do+ R.string hdrName+ R.skipSpaces+ R.char ':'+ R.skipSpaces+ xs <- R.many R.get+ R.satisfy ( == '\n' )+ return (Header hdrName xs)++headerVal :: String -> ReadP StrHeader+headerVal name = do + R.string name+ R.skipSpaces+ R.char ':'+ R.skipSpaces+ R.char '<'+ xs <- R.many R.get+ R.char '>'+ return (Header name xs)
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Eugene Dzhurinsky++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 Eugene Dzhurinsky 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.
+ Main.hs view
@@ -0,0 +1,101 @@+module Main(main) where++import CarbonCopy.StorageInit+import CarbonCopy.MailHeaders+import CarbonCopy.HeadersStorage+import CarbonCopy.ThreadBuilder+import CarbonCopy.Configuration++import System+import System.Exit+import System.IO.HVFS+import System.FilePath.Posix++import Data.ByteString.Char8 as BStr+import Data.Maybe++import Control.Monad.IfElse+import Control.Monad++import Prelude as P++emptyStr = BStr.pack ""++data CCState = Ok | NotFound | NoChain deriving ( Enum )++data Opts = Opts { email, storageFileName :: String, storage :: Storage StrHeader }++main = do+ opts <- prepareConfig+ getArgs >>= (processArgs opts)+++processArgs :: Opts -> [String] -> IO ()+processArgs opts args = + case args of+ ("init":folders) -> initPassedFolders folders+ [] -> handlePassedEmail+ _ -> usage+ where+ email' = email opts+ storage' = storage opts+ storageFileName' = storageFileName opts+ initPassedFolders folders = do+ let foldersLength = P.length folders+ unlessM (fileExists storageFileName' ) $ BStr.writeFile storageFileName' emptyStr+ mapM_ (initMailFolder storage' email' foldersLength ) $ P.zip folders [1..]+ handlePassedEmail = BStr.getContents >>= handleEmail storage' email' >>= processCCState+ +++prepareConfig :: IO (Opts)+prepareConfig = do+ home <- getEnv "HOME"+ let configFileName = home </> ".ccrc"+ unlessM ( fileExists configFileName) $ error $ "Configuration file " ++ configFileName ++ " not found"+ configuration <- fmap loadConfiguration $ BStr.readFile configFileName+ let storageFileName = home </> ( fromJust . getPath $ configuration )+ storage = fileStorage storageFileName+ email = fromJust . getEmail $ configuration+ return ( Opts email storageFileName storage )+++usage :: IO ()+usage = do+ progName <- getProgName+ P.putStrLn $ "Usage " ++ progName ++ " [init maildir1 maildir2 maildir3 ...] [ < content ]"+ P.putStrLn $ "\twhere 'init' will initialize header index with messages from given maildirs"+ P.putStrLn $ "\twith no arguments it will read message from stdin and attempt to recognize headers within it"+ P.putStrLn $ "\n\nExit codes:"+ P.putStrLn $ "\t0\t- reply to known thread was found, header was added to the storage"+ P.putStrLn $ "\t1\t- current email does not contain either e-mail address from configuration and is not a reply to a known thread"+ P.putStrLn $ "\t2\t- no message headers were recognized"+++processCCState :: CCState -> IO ()+processCCState state | stateCode == 0 = System.exitWith ExitSuccess+ | otherwise = System.exitWith $ ExitFailure stateCode+ where+ stateCode = fromEnum state+++fileExists :: FilePath -> IO (Bool)+fileExists = vDoesFileExist SystemFS++initMailFolder :: Storage StrHeader -> String -> Int -> (FilePath , Int) -> IO ()+initMailFolder storage email count (mailStorage, idx) = do+ P.putStrLn $ "Processing storage " ++ show idx ++ " of " ++ show count ++ " at " ++ mailStorage+ storageInit email mailStorage storage++handleEmail :: Storage StrHeader -> String -> ByteString -> IO ( CCState )+handleEmail storage email content = handleEmail' chain+ where ( chain, ownerEmail ) = matchFromHeader content email+ handleEmail' (Just chain) = handleEmail'' ownerEmail+ where+ handleEmail'' True = do hdrAdd storage . current $ chain + System.exitWith ExitSuccess+ handleEmail'' _ = do existsInStorage <- saveMatchingChain storage chain+ if existsInStorage+ then return ( Ok )+ else return ( NotFound )+ handleEmail' _ = return ( NoChain )
+ README.txt view
@@ -0,0 +1,47 @@+Many times you are posting some email to a mailing list. Usually you want+to track replies to your email, as well if someone replies to another email+in the thread, posted by another person.++If you are using procmail, you may have it configured to store mails into+separate folders for mailing lists, just to keep yourself organized. However,+you are forced to check those folders periodically, to see if there are new +replies to your emails.++Procmail itself doesn't provide any functionality to track email threads and+notify you if a new email is posted to a thread you've started. So this simple+tool allows to check if email was posted in reply to certain one in the thread.++With simple procmail configuration, like below++:0 cW+* ? /path/to/executable+/home/user/Maildir/CC/++emails will be copied into CC folder, if they are replies to a thread you'd +started.++You have to configure $HOME/.ccrc file as following++cc_header_file = /home/user/.ccheaders+originator_email = user@domain.com++where ++cc_header_file - full path to the database of message IDs+originator_email - email of sender you want to "Watch" for replies automatically.+ Usually this is your own email address.++How this works: every email should have 2 headers:++- Message-Id - the unique ID of email message, generated by MTA+- In-Reply-To - ID of email, which was replied by current one++So the task of the current tool is to check, if there is a value of In-Reply-To header +present in the email database (plain text file), and if so - add the current message ID+to the database and exit with code 0.++We have to add current message ID to make it possible follow-ups of the current email+will be tracked as well.++If email message contains originator_email from settings file, then current ID of the+email will be added to the storage as well. So follow-ups will be tracked as well
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ carboncopy.cabal view
@@ -0,0 +1,72 @@+-- carboncopy.cabal auto-generated by cabal init. For additional+-- options, see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package.+Name: carboncopy++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version: 0.1++-- A short (one-line) description of the package.+Synopsis: Drop emails from threads being watched into special CC folder.++-- A longer description of the package.+Description: See README.txt++-- URL for the project homepage or repository.+Homepage: http://github.com/jdevelop/carboncopy++-- The license under which the package is released.+License: BSD3++-- The file containing the license text.+License-file: LICENSE++-- The package author(s).+Author: Eugene Dzhurinsky++-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: jdevelop@gmail.com++-- A copyright notice.+-- Copyright: ++Category: Email++Build-type: Simple++-- Extra files to be distributed with the package, such as examples or+-- a README.+Extra-source-files: README.txt, + CarbonCopy/Configuration.hs,+ CarbonCopy/EmailStorage.hs,+ CarbonCopy/HeadersStorage.hs,+ CarbonCopy/MailHeaders.hs,+ CarbonCopy/StorageInit.hs,+ CarbonCopy/ThreadBuilder.hs++-- Constraint on the version of Cabal needed to build this package.+Cabal-version: >=1.2+++Executable carboncopy+ -- .hs or .lhs file containing the Main module.+ Main-is: Main.hs+ + -- Packages needed in order to build this package.+ Build-depends: base >= 3 && < 4,+ IfElse >= 0.85,+ bytestring >= 0.9.1.4,+ filepath >= 1.1.0.2,+ MissingH >= 1.1.0.1,+ haskell98+ + -- Modules not exported by this package.+ -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: +