HackMail (empty) → 0.0
raw patch · 12 files changed
+689/−0 lines, 12 filesdep +Cryptodep +basedep +directorysetup-changed
Dependencies added: Crypto, base, directory, hdaemonize, hint, mtl, old-time, parsec
Files
- HackMail.cabal +43/−0
- HackMail/Control/Checksum.hs +50/−0
- HackMail/Control/Misc.hs +80/−0
- HackMail/Data/Deliverable.hs +76/−0
- HackMail/Data/Email.hs +48/−0
- HackMail/Data/FilterConf.hs +13/−0
- HackMail/Data/MainTypes.hs +79/−0
- HackMail/Data/ParseEmail.hs +158/−0
- HackMail/Data/Path.hs +103/−0
- LICENSE +30/−0
- Main.hs +6/−0
- Setup.lhs +3/−0
+ HackMail.cabal view
@@ -0,0 +1,43 @@+Name: HackMail+Version: 0.0+Synopsis: A Procmail Replacement as Haskell EDSL +Description: A program for filtering/sorting email. Monadic EDSL for sorting, supports multiple mail storage formats. +Homepage: http://patch-tag.com/publicrepos/Hackmail+Package-Url: http://patch-tag.com/publicrepos/Hackmail+Category: Network+License: BSD3+License-file: LICENSE+Author: Joe Fredette+Maintainer: jfredett@gmail.com+Build-Type: Simple+Cabal-Version: >=1.6++Library + Build-Depends: base,+ directory >= 1.0,+ Crypto >= 4.2,+ parsec >= 2.1,+ mtl >= 1.1,+ old-time >= 1.0,+ hint >= 0.3+ Exposed-Modules: HackMail.Data.MainTypes,+ HackMail.Data.Email,+ HackMail.Data.ParseEmail,+ HackMail.Data.Path,+ HackMail.Data.Deliverable,+ HackMail.Data.FilterConf+ HackMail.Control.Misc+ HackMail.Control.Checksum+ + +Executable hackmail+ Main-is: Main.hs+ Build-Depends: base,+ directory >= 1.0,+ Crypto >= 4.2,+ parsec >= 2.1,+ mtl >= 1.1,+ old-time >= 1.0,+ hdaemonize >= 0.1,+ hint >= 0.3+
+ HackMail/Control/Checksum.hs view
@@ -0,0 +1,50 @@+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- |+--Module : Checksum+--Author : Joe Fredette +--License : BSD3+--Copyright : Joe Fredette+--+--Maintainer : Joe Fredette <jfredett.at.gmail.dot.com>+--Stability : Unstable+--Portability : Portable+--+--------------------------------------------------------------------------------+--Description : Provides a checksum function for strings. The checksum is (mostly)+-- unique to a given string.+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++module HackMail.Control.Checksum (checksum) where++import Data.Digest.SHA2+import Data.Char+import Data.Word+import Data.List+++checksum :: String -> String+checksum = map toChr . map makeReadable . toOctets . sha256Ascii++makeReadable :: Word8 -> Word8+makeReadable c = (toEnum . ord) $ readables !! ((fromEnum c) `mod` (length readables))++toChr :: Word8 -> Char+toChr = (chr . fromEnum) ++readables = "+-_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"+++testChecksum :: IO ()+testChecksum = do+ values <- readFile "testchksum.tx"+ let truevals = nub . lines $ values+ let numvals = length $ truevals+ let chksums = map checksum $ truevals+ putStrLn $ checkeach chksums+ putStrLn $ "Tested: " ++ show numvals ++ " diferent hashes."++checkeach [] = "Passed"+checkeach (x:xs) | all (/=x) xs = checkeach xs+ | otherwise = "Failed with:\n" ++ (show x)
+ HackMail/Control/Misc.hs view
@@ -0,0 +1,80 @@+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+--Module : Misc+--Author : Joe Fredette+--License : BSD3+--Copyright : Joe Fredette+--+--Maintainer : Joe Fredette <jfredett.at.gmail.dot.com>+--Stability : Unstable+--Portability : portable+--+--------------------------------------------------------------------------------+--Description : Misc. helper functions.+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+{-# LANGUAGE FlexibleInstances #-}+module HackMail.Control.Misc where++import Control.Arrow+import Data.Char++if' p t f = if p then t else f++instance Show (a -> b) where+ show _ = "FUNCTION"++pairToList :: ([a],[a]) -> [a]+pairToList (a,b) = a++b+++both :: Arrow a => a b c -> a (b, b) (c, c)+both a = a *** a++double :: Arrow a => a b c -> a b (c,c)+double a = a &&& a +++(^|^) f g (x,y) = first (f x) >>> second (g y)+dupe f = f ^|^ f ++(^&^) f g p i = (f ^|^ g) p $ (i, i)+copy f = f ^&^ f++appBoth :: (a -> b, c -> d) -> a -> c -> (b, d)+appBoth (f,g) x y = (f x, g y)++appDouble :: (a -> b, a -> b) -> a -> (b,b)+appDouble (f,g) x = (f x, g x)+++++--- (map foo *** map bar) quux -> (dupe map) (foo, bar) quux +--+-- a1 (a2 b c) (a2 (f a) (f b)) +++--- Maybe stuff...++maybeToBool :: Maybe a -> Bool+maybeToBool Nothing = False+maybeToBool _ = True++-- These are pulled out of my ass, are they useful at all? +maybeAnd, maybeOr :: Maybe a -> Maybe a -> Maybe (a,a)+maybeIf :: Maybe a -> Maybe a -> Maybe a -> Maybe a++maybeAnd Nothing _ = Nothing+maybeAnd _ Nothing = Nothing+maybeAnd (Just a) (Just b) = Just (a,b)++maybeOr Nothing Nothing = Nothing+maybeOr Nothing (Just b) = Just (b,b)+maybeOr (Just a) Nothing = Just (a,a)+maybeOr (Just a) (Just b) = Just (a,b)++maybeIf Nothing Nothing _ = Nothing+maybeIf Nothing (Just a) _ = Just a+maybeIf (Just a) _ Nothing = Nothing+maybeIf (Just a) _ (Just b) = Just b
+ HackMail/Data/Deliverable.hs view
@@ -0,0 +1,76 @@+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- |+--Module : Deliverable+--Author : Joe Fredette+--License : BSD3+--Copyright : Joe Fredette+--+--Maintainer : Joe Fredette <jfredett.at.gmail.dot.com>+--Stability : Unstable+--Portability : Portable +--+--------------------------------------------------------------------------------+--Description : Provides a class + instances which abstract over mailbox format+-- types. Currently provides a flat-file and (Slightly broken) Maildir format. +-- also contains some combinators for dealing with new instances of Deliverable. +--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+{-# LANGUAGE DeriveDataTypeable, GADTs #-}+module HackMail.Data.Deliverable where++import HackMail.Data.Email +import HackMail.Data.Path++import Control.Monad.Reader+import System.Directory+import System.IO+import Data.Typeable++-- | The main class which abstracts over delivery of datatype to somewhere in the file system.+-- It also abstracts over construction. Due to some weirdity w.r.t. Hint, this, and all instancing+-- datatypes, must derive Typeable. A bit of boilerplate, but deriving generally handles it easily.+class Typeable a => Deliverable a where+ deliverIO :: a -> IO ()+ construct :: Email -> Path -> a +++data DEMail = DE { email :: Email+ , path :: Path+ }+ deriving (Eq, Show, Typeable) ++newtype FlatEmail = Flat DEMail+ deriving (Show, Eq, Typeable)++instance Deliverable FlatEmail where+ construct e p = Flat $ DE e p+ deliverIO (Flat (DE e p)) = do+ let msgPath = getDeliveryPath (DE e p)+ writeEmail e (toFilePath p) msgPath++newtype MaildirEmail = MD DEMail+ deriving (Show, Eq, Typeable)++-- TODO: Make this _actually_ create the cur and tmp dirs too.+instance Deliverable MaildirEmail where+ construct e p = MD $ DE e p+ deliverIO (MD (DE e p)) = do+ let newDirPath = p +/+ (parse "new")+ let msgPath = (getDeliveryPath (DE e newDirPath))+ writeEmail e (toFilePath newDirPath) msgPath++getDeliveryPath :: DEMail -> FilePath+getDeliveryPath (DE e p) = mkDeliverablePath p ("msg-" ++ (emailChecksum e) ++ ".eml")++data ToDelivery where Wrap :: Deliverable a => a -> ToDelivery+ deriving (Typeable)++delivery :: ToDelivery -> IO ()+delivery (Wrap x) = deliverIO x++++++
+ HackMail/Data/Email.hs view
@@ -0,0 +1,48 @@+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- |+--Module : Email+--Author : Joe Fredette+--License : BSD3+--Copyright : Joe Fredette+--+--Maintainer : Joe Fredette <jfredett.at.gmail.dot.com>+--Stability : Unstable+--Portability : Portable+--+--------------------------------------------------------------------------------+--Description : Email Data type, parsing functions, helper functions. +--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++module HackMail.Data.Email ( module HackMail.Data.ParseEmail+ , module HackMail.Control.Checksum+ , writeEmail+ , emailChecksum + , grabTokValUnsafe, grabTokVal+ ) where++import HackMail.Data.ParseEmail+import HackMail.Control.Checksum+import System.IO+import System.Directory+++writeEmail :: Email -> FilePath -> FilePath -> IO ()+writeEmail e dirPath msgPath = do+ createDirectoryIfMissing True dirPath+ writeFile msgPath (show e) ++emailChecksum :: Email -> String+emailChecksum e = checksum . show $ e++grabTokValUnsafe :: Email -> HeaderTok -> String+grabTokValUnsafe (Email h _) htok = findTok h htok+ where findTok STOP _ = ""+ findTok (HDR h1 s hdrNext) hgvn = if (h1 == hgvn) then s else (findTok hdrNext hgvn)++grabTokVal :: Email -> HeaderTok -> Maybe String+grabTokVal e htok + | unsafe == "" = Nothing+ | otherwise = Just unsafe+ where unsafe = grabTokValUnsafe e htok
+ HackMail/Data/FilterConf.hs view
@@ -0,0 +1,13 @@+module HackMail.Data.FilterConf + ( module HackMail.Data.MainTypes+ , module HackMail.Data.Deliverable+ , module HackMail.Control.Misc+ , module Control.Monad.Reader+ )+ where +++import HackMail.Data.MainTypes hiding (inboxLoc, filterMain)+import HackMail.Data.Deliverable+import HackMail.Control.Misc+import Control.Monad.Reader
+ HackMail/Data/MainTypes.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+module HackMail.Data.MainTypes ( module HackMail.Data.Path+ , module HackMail.Data.Email+ , Options (..), getOpts+ , Config (..)+ , Filter (..), runFilter) where++import Control.Arrow+import Control.Applicative+import Control.Monad+import Control.Monad.Reader++import Data.List+import Data.Typeable++-- TODO: Export Deliverable from here to?+import HackMail.Control.Misc+import HackMail.Data.Path+import HackMail.Data.Email +import HackMail.Data.ParseEmail++data SortOpt a = EqOpt a | RegOpt a+ deriving Show++data Options = Opt { daemonMode :: Bool+ , incomingMailLoc :: Maybe FilePath -- only needed if daemonMode |- True+ , altFMainLoc :: Maybe FilePath -- not currently used.+ }+ deriving (Eq, Show) ++-- |A type mostly used in Hackmain.hs, stores some information about paths. Only here to avoid nasty+-- mutually recursive modules. (TODO: Move this and associated functions another module?) +data Config = Conf { inboxLoc :: Path + , filterMainLoc :: FilePath+ , filterMain :: Filter () + } -- what exactly do I need to store in the config? + deriving (Typeable)++instance Show Config where+ show (Conf inbox filterMain _) = "Conf | inbox :=" ++ (show inbox) + ++ " FilterMain := " ++ filterMain ++getOpts = parseOpts+ <<< map optNormalForm <<< pairToList + <<< (dupe map) (EqOpt, RegOpt) <<< (copy filter) (eqOpt, regOpt) + where -- catches if an option is of the form -x=blah + eqOpt = any (=='=')+ -- catches options of the form "-d foo"+ regOpt = not . eqOpt+ isOpt (c:_) = (c `elem` "+-")++optNormalForm :: SortOpt String -> (String, String)+optNormalForm (EqOpt s) = both tail . break (=='=') $ s +optNormalForm (RegOpt s) = both tail . break (==' ') $ s ++parseOpts :: [(String, String)] -> Options+parseOpts s = Opt dMode incMailLoc altFMain + where dMode = maybeToBool . findOpt "d" $ s+ incMailLoc = findOpt "i" s + altFMain = findOpt "c" s ++findOpt :: String -> [(String, String)] -> Maybe String +findOpt b s = snd <$> find (\(x,y) -> x == b) s+++-- has to be here, otherwise it cycles imports.++-- |A simple type to contain the email context. May become bigger, to store configuration details,+-- etc.+newtype Filter a = Filter (ReaderT (Config, Email) IO a)+ deriving (Monad, Functor, Typeable, MonadReader (Config, Email), MonadIO)++runFilter :: Filter a -> (Config, Email) -> IO a+runFilter (Filter f) = runReaderT f+--- Typable instance time.++ ++
+ HackMail/Data/ParseEmail.hs view
@@ -0,0 +1,158 @@+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- |+--Module : ParseEmail+--Author : Joe Fredette+--License : BSD3+--Copyright : Joe Fredette+--+--Maintainer : Joe Fredette <jfredett.at.gmail.dot.com>+--Stability : Unstable+--Portability : Portable +--+--------------------------------------------------------------------------------+--Description : Parses email, exports a datatype for email storage.+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+{-# LANGUAGE DeriveDataTypeable #-}+module HackMail.Data.ParseEmail + ( Email (..)+ , Header (..)+ , Body (..)+ , HeaderTok (..)+ , parseEmail+ , parseEmailFromFile+ , matchHdr) where+{- Known issues:+ - Nonconformity to RFC2822+ - Body allows \n, \r, and \r\n (CR, LF, LFCR) instead of the required \n\r+ - (CRLF) - Section 2.3 of the RFC+ - + - Headers don't dump w/ appropriate hyphenation. + - Part of the parsing removes hyphens from the fields, we need some way to+ - put these back when printing out. (is this really a problem? the test + - outputs look different then the show instance would indicate.) should be+ - mostly fixed, not sure on all the details.+ -+ -}++-- Have to hack one up ourselves...+import Text.ParserCombinators.Parsec+import Data.Char+import Data.Typeable++-- TODO: rederive show to format better...+data Email = Email Header Body + deriving (Eq, Typeable)++instance Show Email where+ show (Email header (Body ss)) = show header+ ++ (unlines (filter (/="\r") ss)) ++newtype Body = Body [String]+ deriving (Eq, Typeable)++-- doesn't print quite the way I want...+instance Show Body where+ show (Body []) = "\n"+ show (Body (x:xs)) = trim x ++ "\n" ++ (show xs)+ +-- TODO: rederive show to format better+data Header = HDR HeaderTok String Header+ | STOP+ deriving (Eq, Typeable)++instance Show Header where+ show STOP = "\n"+ show (HDR ht s nextHdr) = show ht ++ ": " ++ s ++ "\n" + ++ show nextHdr++data HeaderTok = TO | DATE | FROM | SENDER | REPLYTO | CC | BCC | MESSAGEID | INREPLYTO | REFERENCES+ | SUBJECT | KEYWORDS | XFIELD String+ deriving (Eq, {-Hack-} Read, Typeable)++instance Show HeaderTok where + show TO = "To"+ show DATE = "Date"+ show FROM = "From"+ show SENDER = "Sender"+ show REPLYTO = "Reply-To"+ show CC = "Cc"+ show BCC = "Bcc"+ show MESSAGEID = "Message-ID"+ show INREPLYTO = "In-Reply-To"+ show REFERENCES = "References"+ show SUBJECT = "Subject"+ show KEYWORDS = "Keywords"+ show (XFIELD s) = s+--+-- The parser proper.+--+parseEmail e = parse parserEmail "" e+parseEmailFromFile path = parseFromFile parserEmail path++eol = try (string "\n\r")+ <|> try (string "\r\n") + <|> string "\n"+ <|> string "\r"+ <?> "EOL character"++valueChar = anyChar -- see rfc2822, section 2.2.+fieldChar = oneOf fieldChar' +fieldChar' = "<>"++['\33'..'\57']++['\59'..'\126'] -- ibid+parserEmail = do+ -- this gives a list of pairs (field, value), we mangle them appropriately below+ header <- many1 parseHeaderline+ eol+ -- just a list of lines. ideally.+ body <- buildBody + eof+ -- now we do some mangling+ let headerRet = buildHeader header+ let bodyRet = Body body+ return (Email headerRet bodyRet)++parseHeaderline = do+ -- actual parsing stuff.+ field <- many1 fieldChar + choice [try $ string ": \n", try $ string ": ", try $ string ":"]+ value <- manyTill valueChar (try trueEndCond)+ return (field, value)+++buildHeader [] = STOP+buildHeader ((f,v):xs) = HDR (matchHdr f) v + $ buildHeader xs++matchHdr :: String -> HeaderTok +matchHdr s = match (map toUpper $ filter (isAlpha) s) s++match :: String -> String -> HeaderTok+match "TO" _ = TO+match "DATE" _ = DATE+match "FROM" _ = FROM+match "SENDER" _ = SENDER+match "REPLYTO" _ = REPLYTO+match "CC" _ = CC+match "BCC" _ = BCC+match "MESSAGEID" _ = MESSAGEID+match "INREPLYTO" _ = INREPLYTO+match "REFERENCES" _ = REFERENCES+match "SUBJECT" _ = SUBJECT+match "KEYWORDS" _ = KEYWORDS+match _ s' = XFIELD s'+++buildBody = sepBy (many $ noneOf "\n\r") eol++trimLeft s = dropWhile isSpace s+trimRight s = reverse . trimLeft . reverse +trim = trimRight $ trimLeft++whitespace = oneOf "\t "++-- catches CRLF+Whitespaces that precede longfields.+trueEndCond = do+ eol+ notFollowedBy whitespace+
+ HackMail/Data/Path.hs view
@@ -0,0 +1,103 @@+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------+-- |+--Module : Path+--Author : Joe Fredette+--License : BSD3+--Copyright : Joe Fredette+--+--Maintainer : Joe Fredette <jfredett.at.gmail.dot.com>+--Stability : Unstable+--Portability : Not portable (*nix style only) +--+--------------------------------------------------------------------------------+--Description : Portable interaction with filesystem Paths, currently only works+-- with *nix paths (where *nix path is of the form "/usr/bin/.../"+--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++module HackMail.Data.Path + ( Path (..)+ , VPath (..)+ , parse, parseV+ , splitOn, (+/+)+ , liftToPath1, liftToPath2 + , pathExists, mkDeliverablePath+ , toFilePath+ ) where++{- Needs to be rewritten to handle Windows/*nix/etc paths,+ - Needs to be rewritten to use Parsec + - Needs Documentation+ -}+++--import Text.ParserCombinators.Parsec+import Data.List+import System.Directory+++{- Here we define a type which parses paths from Unix/Windows/etc into a generic type. -}+type FileName = String++data Path = P { virtualPath :: VPath+ , relative :: Bool + }+ deriving (Eq, Show)++data VPath = VPath :/: String + | Root + deriving (Eq)++instance Show VPath where+ show Root = ""+ show (d :/: r) = (show d) ++ "/" ++ r++-- for now, this is hackish but it works.++parse :: FilePath -> Path+parse "" = error "Cannot parse an empty path"+parse s@(c:cs) + | c == '/' = P (adj cs) False+ | otherwise = P (adj s) True+ where adj q = parseV $ if last q == '/' then q else q++"/"++parseV :: FilePath -> VPath+parseV s = fromList tokPath+ where tokPath = splitOn '/' s+++splitOn :: Eq a => a -> [a] -> [[a]]+splitOn _ [] = []+splitOn c ls = f : (splitOn c (tail l))+ where (f, l) = span (/=c) ls +++++(+/+) :: Path -> Path -> Path+(+/+) = (liftToPath2 catVPaths) +catVPaths :: VPath -> VPath -> VPath+catVPaths p q = fromList $ (toList p) ++ (toList q)+++toList :: VPath -> [String]+toList Root = []+toList (p :/: p') = (toList p) ++ [p']++fromList :: [String] -> VPath+fromList tokPath = foldl (:/:) Root tokPath++pathExists :: Path -> IO Bool+pathExists (P p b) = doesDirectoryExist (adj $ show p)+ where adj = if b then tail else id++mkDeliverablePath :: Path -> FileName -> FilePath+mkDeliverablePath (P p b) fn = adj $ (show p) ++ "/" ++ fn+ where adj = if b then tail else id++toFilePath :: Path -> FilePath+toFilePath p = mkDeliverablePath p ""++liftToPath1 f (P p b) = (P (f p) b)+liftToPath2 f (P p1 b1) (P p2 b2) = (P (f p1 p2) b1)
+ LICENSE view
@@ -0,0 +1,30 @@+++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 ; nor the names of its 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,6 @@+module Main where++import qualified HackMail.Hackmain as H++main :: IO () +main = H.main
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain