diff --git a/CarbonCopy/Configuration.hs b/CarbonCopy/Configuration.hs new file mode 100644 --- /dev/null +++ b/CarbonCopy/Configuration.hs @@ -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 diff --git a/CarbonCopy/EmailStorage.hs b/CarbonCopy/EmailStorage.hs new file mode 100644 --- /dev/null +++ b/CarbonCopy/EmailStorage.hs @@ -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 diff --git a/CarbonCopy/HeadersStorage.hs b/CarbonCopy/HeadersStorage.hs new file mode 100644 --- /dev/null +++ b/CarbonCopy/HeadersStorage.hs @@ -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 diff --git a/CarbonCopy/MailHeaders.hs b/CarbonCopy/MailHeaders.hs new file mode 100644 --- /dev/null +++ b/CarbonCopy/MailHeaders.hs @@ -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" diff --git a/CarbonCopy/StorageInit.hs b/CarbonCopy/StorageInit.hs new file mode 100644 --- /dev/null +++ b/CarbonCopy/StorageInit.hs @@ -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 () diff --git a/CarbonCopy/ThreadBuilder.hs b/CarbonCopy/ThreadBuilder.hs new file mode 100644 --- /dev/null +++ b/CarbonCopy/ThreadBuilder.hs @@ -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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 ) diff --git a/README.txt b/README.txt new file mode 100644 --- /dev/null +++ b/README.txt @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/carboncopy.cabal b/carboncopy.cabal new file mode 100644 --- /dev/null +++ b/carboncopy.cabal @@ -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: +