diff --git a/HackMail.cabal b/HackMail.cabal new file mode 100644 --- /dev/null +++ b/HackMail.cabal @@ -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 + diff --git a/HackMail/Control/Checksum.hs b/HackMail/Control/Checksum.hs new file mode 100644 --- /dev/null +++ b/HackMail/Control/Checksum.hs @@ -0,0 +1,50 @@ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- | +--Module : Checksum +--Author : Joe Fredette +--License : BSD3 +--Copyright : Joe Fredette +-- +--Maintainer : Joe Fredette +--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) diff --git a/HackMail/Control/Misc.hs b/HackMail/Control/Misc.hs new file mode 100644 --- /dev/null +++ b/HackMail/Control/Misc.hs @@ -0,0 +1,80 @@ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +--Module : Misc +--Author : Joe Fredette +--License : BSD3 +--Copyright : Joe Fredette +-- +--Maintainer : Joe Fredette +--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 diff --git a/HackMail/Data/Deliverable.hs b/HackMail/Data/Deliverable.hs new file mode 100644 --- /dev/null +++ b/HackMail/Data/Deliverable.hs @@ -0,0 +1,76 @@ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- | +--Module : Deliverable +--Author : Joe Fredette +--License : BSD3 +--Copyright : Joe Fredette +-- +--Maintainer : Joe Fredette +--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 + + + + + + diff --git a/HackMail/Data/Email.hs b/HackMail/Data/Email.hs new file mode 100644 --- /dev/null +++ b/HackMail/Data/Email.hs @@ -0,0 +1,48 @@ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- | +--Module : Email +--Author : Joe Fredette +--License : BSD3 +--Copyright : Joe Fredette +-- +--Maintainer : Joe Fredette +--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 diff --git a/HackMail/Data/FilterConf.hs b/HackMail/Data/FilterConf.hs new file mode 100644 --- /dev/null +++ b/HackMail/Data/FilterConf.hs @@ -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 diff --git a/HackMail/Data/MainTypes.hs b/HackMail/Data/MainTypes.hs new file mode 100644 --- /dev/null +++ b/HackMail/Data/MainTypes.hs @@ -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. + + + + diff --git a/HackMail/Data/ParseEmail.hs b/HackMail/Data/ParseEmail.hs new file mode 100644 --- /dev/null +++ b/HackMail/Data/ParseEmail.hs @@ -0,0 +1,158 @@ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- | +--Module : ParseEmail +--Author : Joe Fredette +--License : BSD3 +--Copyright : Joe Fredette +-- +--Maintainer : Joe Fredette +--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 + diff --git a/HackMail/Data/Path.hs b/HackMail/Data/Path.hs new file mode 100644 --- /dev/null +++ b/HackMail/Data/Path.hs @@ -0,0 +1,103 @@ +-------------------------------------------------------------------------------- +-------------------------------------------------------------------------------- +-- | +--Module : Path +--Author : Joe Fredette +--License : BSD3 +--Copyright : Joe Fredette +-- +--Maintainer : Joe Fredette +--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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + + diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import qualified HackMail.Hackmain as H + +main :: IO () +main = H.main 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