Mhailist (empty) → 0.0
raw patch · 17 files changed
+1603/−0 lines, 17 filesdep +HUnitdep +basedep +binarysetup-changed
Dependencies added: HUnit, base, binary, bytestring, directory, filepath, haskell98, mtl, old-locale, process, time
Files
- Data/Digest/Pure/MD5.hs +275/−0
- LTR/Transaction.hs +265/−0
- LTR/Ttool.hs +153/−0
- Mhailist.cabal +48/−0
- Mhailist.hs +6/−0
- Mhailist/Address.hs +140/−0
- Mhailist/BuildMessage.hs +142/−0
- Mhailist/Error.hs +20/−0
- Mhailist/List.hs +81/−0
- Mhailist/Message.hs +116/−0
- Mhailist/Receive.hs +96/−0
- Mhailist/Transaction.hs +66/−0
- README +19/−0
- Setup.hs +3/−0
- Test.hs +18/−0
- UnitTest.hs +102/−0
- Util/String.hs +53/−0
+ Data/Digest/Pure/MD5.hs view
@@ -0,0 +1,275 @@+{-# OPTIONS_GHC -XBangPatterns #-}+-----------------------------------------------------------------------------+--+-- Module : Data.Digest.MD5+-- License : BSD3+-- Maintainer : Thomas.DuBuisson@mail.google.com+-- Stability : experimental+-- Portability : portable, requires bang patterns and ByteString+-- Tested with : GHC-6.8.1+--+-- |To get an MD5 digest of a lazy ByteString (you probably want this):+-- hash = md5 lazyByteString+--+-- Alternativly, for a context that can be further updated/finalized:+-- partialCtx = md5Update md5InitialContext partOfFile+--+-- And you finialize the context with:+-- hash = md5Finalize partialCtx+-----------------------------------------------------------------------------++module Data.Digest.Pure.MD5+ (+ -- * Types+ MD5Context+ , MD5Digest+ -- * Static data+ , md5InitialContext+ , blockSize+ -- * Functions+ , md5+ , md5Update+ , md5Finalize+ ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.ByteString.Internal+import Data.Bits+import Data.List+import Data.Int (Int64)+import Foreign.Storable+import Foreign.Ptr+import Foreign.ForeignPtr+import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import Numeric++-- | Block size in bits+blockSize :: Int+blockSize = 512++blockSizeBytes = blockSize `div` 8+blockSizeBytesI64 = (fromIntegral blockSizeBytes) :: Int64+blockSizeBits = (fromIntegral blockSize) :: Word64++data MD5Partial = MD5Par !Word32 !Word32 !Word32 !Word32+ deriving (Ord, Eq)++-- | The type for intermediate and final results.+data MD5Context = MD5Ctx { mdPartial :: !MD5Partial,+ mdLeftOver :: ByteString,+ mdTotalLen :: !Word64 }++-- |After finalizing a context, using md5Finalize, a new type+-- is returned to prevent 're-finalizing' the structure.+newtype MD5Digest = MD5Digest MD5Context++-- | The initial context to use when calling md5Update for the first time+md5InitialContext :: MD5Context+md5InitialContext = MD5Ctx (MD5Par h0 h1 h2 h3) B.empty 0+h0 = 0x67452301+h1 = 0xEFCDAB89+h2 = 0x98BADCFE+h3 = 0x10325476++-- | Processes a lazy ByteString and returns the md5 digest.+-- This is probably what you want.+md5 :: L.ByteString -> MD5Digest+md5 bs = md5Finalize $ md5Update md5InitialContext bs++-- | Closes an MD5 context, thus producing the digest.+md5Finalize :: MD5Context -> MD5Digest+md5Finalize !ctx@(MD5Ctx (MD5Par _a _b _c _d) rem !totLen) =+ let totLen' = (totLen + 8*fromIntegral l) :: Word64+ padBS = L.toChunks $ runPut ( do+ putWord8 0x80+ mapM_ putWord8 (replicate lenZeroPad 0)+ putWord64le totLen' )+ in MD5Digest $ md5Update ctx (L.fromChunks padBS)+ where+ l = B.length rem+ lenZeroPad = if (l + 1) <= blockSizeBytes - 8+ then (blockSizeBytes - 8) - (l + 1)+ else (2 * blockSizeBytes - 8) - (l + 1)++-- | Alters the MD5Context with a partial digest of the data.+md5Update :: MD5Context -> L.ByteString -> MD5Context+md5Update !ctx@(MD5Ctx _ !leftover _) bsLazy =+ let bs = L.fromChunks (leftover:L.toChunks bsLazy)+ in blockAndDo ctx bs --foldl' performMD5Update ctx blks++blockAndDo :: MD5Context -> L.ByteString -> MD5Context+blockAndDo !ctx bs =+ if B.length blk == blockSizeBytes+ then let !newCtx = performMD5Update ctx blk+ in blockAndDo newCtx rest+ else ctx { mdLeftOver = blk }+ where+ blk = B.concat $ L.toChunks top+ (top,rest) = L.splitAt blockSizeBytesI64 bs+{-# INLINE blockAndDo #-}++-- Assumes ByteString length == blockSizeBytes, will fold the +-- context across calls to applyMD5Rounds.+performMD5Update :: MD5Context -> ByteString -> MD5Context+performMD5Update !_ctx@(MD5Ctx !par@(MD5Par !a !b !c !d) _ !len) !bs =+ let MD5Par a' b' c' d' = applyMD5Rounds par bs+ in MD5Ctx {+ mdPartial = MD5Par (a' + a) (b' + b) (c' + c) (d' + d),+ mdLeftOver = B.empty,+ mdTotalLen = len + blockSizeBits+ }+{-# INLINE performMD5Update #-}++applyMD5Rounds :: MD5Partial -> ByteString -> MD5Partial+applyMD5Rounds _par@(MD5Par a b c d) w =+ let -- Round 1+ !r0 = ff a b c d (w!!0) 7 3614090360+ !r1 = ff d r0 b c (w!!1) 12 3905402710+ !r2 = ff c r1 r0 b (w!!2) 17 606105819+ !r3 = ff b r2 r1 r0 (w!!3) 22 3250441966+ !r4 = ff r0 r3 r2 r1 (w!!4) 7 4118548399+ !r5 = ff r1 r4 r3 r2 (w!!5) 12 1200080426+ !r6 = ff r2 r5 r4 r3 (w!!6) 17 2821735955+ !r7 = ff r3 r6 r5 r4 (w!!7) 22 4249261313+ !r8 = ff r4 r7 r6 r5 (w!!8) 7 1770035416+ !r9 = ff r5 r8 r7 r6 (w!!9) 12 2336552879+ !r10 = ff r6 r9 r8 r7 (w!!10) 17 4294925233+ !r11 = ff r7 r10 r9 r8 (w!!11) 22 2304563134+ !r12 = ff r8 r11 r10 r9 (w!!12) 7 1804603682+ !r13 = ff r9 r12 r11 r10 (w!!13) 12 4254626195+ !r14 = ff r10 r13 r12 r11 (w!!14) 17 2792965006+ !r15 = ff r11 r14 r13 r12 (w!!15) 22 1236535329+ -- Round 2+ !r16 = gg r12 r15 r14 r13 (w!!1) 5 4129170786+ !r17 = gg r13 r16 r15 r14 (w!!6) 9 3225465664+ !r18 = gg r14 r17 r16 r15 (w!!11) 14 643717713+ !r19 = gg r15 r18 r17 r16 (w!!0) 20 3921069994+ !r20 = gg r16 r19 r18 r17 (w!!5) 5 3593408605+ !r21 = gg r17 r20 r19 r18 (w!!10) 9 38016083+ !r22 = gg r18 r21 r20 r19 (w!!15) 14 3634488961+ !r23 = gg r19 r22 r21 r20 (w!!4) 20 3889429448+ !r24 = gg r20 r23 r22 r21 (w!!9) 5 568446438+ !r25 = gg r21 r24 r23 r22 (w!!14) 9 3275163606+ !r26 = gg r22 r25 r24 r23 (w!!3) 14 4107603335+ !r27 = gg r23 r26 r25 r24 (w!!8) 20 1163531501+ !r28 = gg r24 r27 r26 r25 (w!!13) 5 2850285829+ !r29 = gg r25 r28 r27 r26 (w!!2) 9 4243563512+ !r30 = gg r26 r29 r28 r27 (w!!7) 14 1735328473+ !r31 = gg r27 r30 r29 r28 (w!!12) 20 2368359562+ -- Round 3+ !r32 = hh r28 r31 r30 r29 (w!!5) 4 4294588738+ !r33 = hh r29 r32 r31 r30 (w!!8) 11 2272392833+ !r34 = hh r30 r33 r32 r31 (w!!11) 16 1839030562+ !r35 = hh r31 r34 r33 r32 (w!!14) 23 4259657740+ !r36 = hh r32 r35 r34 r33 (w!!1) 4 2763975236+ !r37 = hh r33 r36 r35 r34 (w!!4) 11 1272893353+ !r38 = hh r34 r37 r36 r35 (w!!7) 16 4139469664+ !r39 = hh r35 r38 r37 r36 (w!!10) 23 3200236656+ !r40 = hh r36 r39 r38 r37 (w!!13) 4 681279174+ !r41 = hh r37 r40 r39 r38 (w!!0) 11 3936430074+ !r42 = hh r38 r41 r40 r39 (w!!3) 16 3572445317+ !r43 = hh r39 r42 r41 r40 (w!!6) 23 76029189+ !r44 = hh r40 r43 r42 r41 (w!!9) 4 3654602809+ !r45 = hh r41 r44 r43 r42 (w!!12) 11 3873151461+ !r46 = hh r42 r45 r44 r43 (w!!15) 16 530742520+ !r47 = hh r43 r46 r45 r44 (w!!2) 23 3299628645+ -- Round 4+ !r48 = ii r44 r47 r46 r45 (w!!0) 6 4096336452+ !r49 = ii r45 r48 r47 r46 (w!!7) 10 1126891415+ !r50 = ii r46 r49 r48 r47 (w!!14) 15 2878612391+ !r51 = ii r47 r50 r49 r48 (w!!5) 21 4237533241+ !r52 = ii r48 r51 r50 r49 (w!!12) 6 1700485571+ !r53 = ii r49 r52 r51 r50 (w!!3) 10 2399980690+ !r54 = ii r50 r53 r52 r51 (w!!10) 15 4293915773+ !r55 = ii r51 r54 r53 r52 (w!!1) 21 2240044497+ !r56 = ii r52 r55 r54 r53 (w!!8) 6 1873313359+ !r57 = ii r53 r56 r55 r54 (w!!15) 10 4264355552+ !r58 = ii r54 r57 r56 r55 (w!!6) 15 2734768916+ !r59 = ii r55 r58 r57 r56 (w!!13) 21 1309151649+ !r60 = ii r56 r59 r58 r57 (w!!4) 6 4149444226+ !r61 = ii r57 r60 r59 r58 (w!!11) 10 3174756917+ !r62 = ii r58 r61 r60 r59 (w!!2) 15 718787259+ !r63 = ii r59 r62 r61 r60 (w!!9) 21 3951481745+ in MD5Par r60 r63 r62 r61+ where+ f !x !y !z = (x .&. y) .|. ((complement x) .&. z)+ {-# INLINE f #-}+ g !x !y !z = (x .&. z) .|. (y .&. (complement z))+ {-# INLINE g #-}+ h !x !y !z = (x `xor` y `xor` z)+ {-# INLINE h #-}+ i !x !y !z = y `xor` (x .|. (complement z))+ {-# INLINE i #-}+ ff a b c d x s ac =+ let !a' = f b c d + x + ac + a+ !a'' = rotateL a' s+ in a'' + b+ {-# INLINE ff #-}+ gg a b c d x s ac =+ let !a' = g b c d + x + ac + a+ !a'' = rotateL a' s+ in a'' + b+ {-# INLINE gg #-}+ hh a b c d x s ac =+ let !a' = h b c d + x + ac + a+ !a'' = rotateL a' s+ in a'' + b+ {-# INLINE hh #-}+ ii a b c d x s ac =+ let !a' = i b c d + x + ac + a+ !a'' = rotateL a' s+ in a'' + b+ {-# INLINE ii #-}+ (!!) word32s pos = getNthWord pos word32s+ {-# INLINE (!!) #-}+ getNthWord n _bs@(PS ptr off _len) =+ inlinePerformIO $ withForeignPtr ptr $ \ptr' -> do+ let p = castPtr $ plusPtr ptr' off+ peekElemOff p n+ {-# INLINE getNthWord #-}+{-# INLINE applyMD5Rounds #-}++----- Some quick and dirty instances follow -----++instance Show MD5Digest where+ show (MD5Digest h) = show h++instance Binary MD5Digest where+ put (MD5Digest (MD5Ctx p _ _)) = put p+ get = do+ p <- get+ return $ MD5Digest $ MD5Ctx p B.empty 0++instance Ord MD5Digest where+ compare (MD5Digest (MD5Ctx a _ _)) (MD5Digest (MD5Ctx b _ _)) = compare a b++instance Eq MD5Digest where+ (MD5Digest (MD5Ctx a _ _)) == (MD5Digest (MD5Ctx b _ _)) = a == b++instance Show MD5Context where+ show (MD5Ctx (MD5Par a b c d) _ _) = + let bs = runPut $ putWord32be d >> putWord32be c >> putWord32be b >> putWord32be a+ in foldl' (\str w -> let c = showHex w str+ in if length c < length str + 2+ then '0':c+ else c) "" (L.unpack bs)++instance Binary MD5Context where+ put (MD5Ctx p r l) = put p >> putWord8 (fromIntegral (B.length r)) >> + putByteString r >> putWord64be l+ get = do p <- get+ s <- getWord8+ r <- getByteString (fromIntegral s)+ l <- getWord64be+ return $ MD5Ctx p r l++instance Binary MD5Partial where+ put (MD5Par a b c d) = putWord32be a >> putWord32be b >> putWord32be c >> putWord32be d+ get = do a <- getWord32be+ b <- getWord32be+ c <- getWord32be+ d <- getWord32be+ return $ MD5Par a b c d
+ LTR/Transaction.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE CPP, NamedFieldPuns, OverloadedStrings #-}++module LTR.Transaction (++ Transaction (..),+ Originator, mkOriginator,+ mkTransaction,+ putTransactionWithoutDigest,+ appendTransaction, getTransactions,++ Word32, Word16,+#ifdef __TEST__+ _testTransaction,+#endif++) where++import Control.Monad (unless)+import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Digest.Pure.MD5+import Data.Time.Clock (UTCTime, diffUTCTime, NominalDiffTime)+import Data.Time.Format (readTime)+import Data.Word (Word32, Word16)+import Util.String ()+import System.IO (IOMode (..), withBinaryFile)+import System.Locale (defaultTimeLocale)++#ifdef __TEST__+import UnitTest+#endif++import qualified Data.ByteString.Lazy.Char8 as B+import qualified Data.ByteString.Char8 as BS++{- Transaction Binary Format++ |---------------------------------------------------------------|+ | magic | v | length |+ |---------------------------------------------------------------|+ | application | flags | t-type |+ |---------------------------------------------------------------|+ | originator |+ |---------------------------------------------------------------|+ | timestamp |+ |---------------------------------------------------------------|+ . .+ . data .+ . .+ |---------------------------------------------------------------|+ | MD5 Digest |+ | |+ |---------------------------------------------------------------|++ Bits Name Description+ ----- --------------- ---------------------------------------------------+ 24 magic Identifies the start of a transaction; always "cjs".+ 08 version Transaction format version: currently 0.+ 48 length The length of the entire transaction, including+ the header and MD5 digest.+ 32 application The number assigned to the particular program or+ system that generates and uses this transaction.+ These numbers are assigned by a central authority.+ However, the range 0xff000000 through 0xfffeffff is+ desginated for "experimental" use, and will never+ be assigned.+ 16 flags Currently reserved and must be set to all zeros.+ (A "compressed data" flag will be added soon.)+ 16 t-type Transaction type; assigned by the application.+ 64 originator A globally-unique node ID for a particular generator+ of transactions. How this is assigned is yet to be+ determined.+ 64 timestamp Signed number of milliseconds since the Unix epoch,+ 1970-01-01 00:00:00 UTC.+ n data A variable amount of data.+ 128 digest An MD5 digest of the header (inc. length) and data.++-}++----------------------------------------------------------------------++-- | A transaction and associated data, if valid. Note that because the+-- constructors are exposed for pattern matching, it's possible to build+-- an invalid 'Transaction'; expect writing such things to fail. Always+-- use 'mkTransaction' to create a transaction.+--+-- 'transRawData' does not include the digest at the end.+--+data Transaction+ = InvalidTransaction String+ | Transaction+ { transApp :: Word32+ , transType :: Word16+ , transOriginator :: Originator+ , transTS :: NominalDiffTime+ , transData :: ByteString+ , transRawData :: ByteString+ , transID :: MD5Digest+ }+ deriving (Show, Eq)++newtype Originator = Originator ByteString+ deriving (Show, Eq)++----------------------------------------------------------------------++-- XXX Temporarially, originators are always zero.+mkOriginator :: Int -> Originator+mkOriginator 0 = Originator "\0\0\0\0\0\0\0\0"+mkOriginator _ = error "Transaction.mkOriginator: write me"++epoch = readTime defaultTimeLocale "" "" :: UTCTime++milliseconds :: NominalDiffTime -> Word64+milliseconds t = round $ 1000 * toRational t++----------------------------------------------------------------------++-- | Create a valid transaction. Transactions created using the data+-- constructors directly are likely to be invalid, and be silently+-- corrupted when written.+--+mkTransaction :: Word32 -> Word16 -> Originator+ -> NominalDiffTime -> ByteString -> Transaction+mkTransaction app ttype orig ts tdata =+ Transaction { transApp = app+ , transType = ttype+ , transOriginator = orig+ , transTS = ts+ , transData = tdata+ , transRawData = rawData+ , transID = digest+ }+ where+ rawData = runPut $ putTransactionWithoutDigest app ttype orig ts tdata+ digest = md5 rawData++instance Binary Transaction where++ get = do magic <- getLazyByteString 3+ unless (magic == "cjs")+ $ error $ "XXX Bad transaction magic number"+ version <- getWord8+ unless (version == 0)+ $ error $ "XXX Bad transaction version: " ++ show version+ lengthHi <- getWord16be+ unless (lengthHi == 0)+ $ error $ "XXX Packet too long for this implementation: "+ ++ "lengthHi=" ++ show lengthHi+ lengthLo <- getWord32be+ let dataLen = (fromIntegral lengthLo) - (8 * 6)+ app <- getWord32be+ flags <- getWord16be+ ttype <- getWord16be+ orig <- get+ ts <- get+ tdata <- getLazyByteString dataLen+ let rawData = B.concat [magic, encode version, encode lengthHi,+ encode lengthLo, encode app, encode flags,+ encode ttype, encode orig, encode ts,+ tdata]+ digest <- get :: Get MD5Digest+ unless (digest == md5 rawData)+ $ error.concat $ [ "XXX transaction digest does not match: "+ , "expected=", show digest, ", "+ , "computed=", show (md5 rawData) ]+ return $! Transaction + { transApp = app+ , transType = ttype+ , transOriginator = orig+ , transTS = ts+ , transData = tdata+ , transRawData = rawData+ , transID = digest+ }++ put InvalidTransaction{} = fail "Cannot put an InvalidTransaction"+ put Transaction{transRawData,transID} = do putLazyByteString transRawData+ put transID+ ++putTransactionWithoutDigest+ :: Word32 -> Word16 -> Originator -> NominalDiffTime -> ByteString -> Put+putTransactionWithoutDigest app ttype orig ts tdata =+ do putLazyByteString magic+ putWord8 version+ putWord16be lengthHi+ -- XXX Should check length+ let lengthLo = (fromIntegral $ B.length tdata) + (8 * 6)+ putWord32be lengthLo+ putWord32be app+ putWord16be flags+ putWord16be ttype+ put orig+ put ts+ putLazyByteString tdata+ where+ magic = "cjs" :: ByteString+ version = 0+ lengthHi = 0+ flags = 0++instance Binary Originator where+ get = getLazyByteString 8 >>= return . Originator+ put (Originator o) = putLazyByteString o++instance Binary NominalDiffTime where+ get = do ms <- getWord64be+ return $ fromIntegral ms / 1000+ put = put . milliseconds ++----------------------------------------------------------------------++-- |Safely appends the transaction to the given file, ensuring that no+-- other process using this will write the file at the same time.+--+appendTransaction :: FilePath -> Transaction -> IO ()+appendTransaction path trans =+ withBinaryFile path AppendMode (\h -> B.hPut h $ encode trans)++getTransactions :: FilePath -> IO [Transaction]+getTransactions path = withBinaryFile path ReadMode (\h ->+ -- get contents not lazily because after this block+ -- the handle will be closed+ do bs <- BS.hGetContents h+ (return . getList) (B.pack $ BS.unpack bs))+ where getList bs | B.null bs = []+ | otherwise = let (trans, rest, _) = runGetState get bs 0+ in trans:(getList rest)++----------------------------------------------------------------------++#ifdef __TEST__+testdataOriginator = Originator "\0\1\2\3\4\5\6\7"++testdataTime = oneMinute `diffUTCTime` epoch+ where oneMinute = readTime defaultTimeLocale "%M" "01" :: UTCTime++testdataApp = 0xffeeddcc+testdataType = 0xfedc+testdataTransaction =+ mkTransaction testdataApp+ testdataType+ testdataOriginator+ testdataTime+ "Hello, world."++testdataBinaryTransaction = B.concat+ [ "cjs", "\0", "\0\0\0\0\0\61" -- magic, ver, len+ , "\xff\xee\xdd\xcc", "\0\0", "\xfe\xdc" -- app, flags, type+ , "\0\1\2\3\4\5\6\7" -- originator+ , "\0\0\0\0\0\0\234\96" -- timestamp, 1 min.+ , "Hello, world." -- data+ , "_\166\201OjT\a\194a\ESC%o\DC3\148_\236" -- md5+ ]++_testTransaction = runTests $ "LTR.Transaction" ~: test + [ show epoch ~?= "1970-01-01 00:00:00 UTC"+ , mkOriginator 0 ~?= Originator "\0\0\0\0\0\0\0\0"+ , encode testdataTransaction ~?= testdataBinaryTransaction+ , decode testdataBinaryTransaction ~?= testdataTransaction+ ]+#endif
+ LTR/Ttool.hs view
@@ -0,0 +1,153 @@+{-# OPTIONS_GHC -XOverloadedStrings #-}++{-+ Read or write a transaction to or from a disk file.++ Usage:+ ttool append TFILE APP TYPE (-d DATA | -f FILE) [-t TS]+ ttool dump TFILE + ttool undump FILE++ Commands:+ append Append a transaction to a file. If the file does not+ exist, it will be created.+ dump Dump, in human-readable format, the transactions from+ a transaction file.+ undump Read dump output (though many input fields are optional)+ and convert it to binary format, sending it to stdout.++ Arguments:+ TFILE a transaction log file.+ APP application number (32-bit unsigned decimal)+ TYPE type number (16-bit unsigned decimal)++ Options:+ Options may be interspersed anywhere within the command line.+ Files that start with a hyphen should be specified as "./-name".++ -t TS Specify a timestamp, in milliseconds since the epoch.+ If not specified, the current time is used.+ -d DATA Specify as a string data to be written to the file.+ -f FILE Specify a file containing the transaction data.++ Notes:++ Application Numbers: 1 testing, 2 mhailist++ Add an option for lock testing? This could write part of the+ transaction, delay, and then write the other part. While that's+ running in the background, you can run another one on the same+ file in the foreground and ensure that a valid transaction log+ is produced.++ Until we get the originator stuff worked out, the originator is+ always zero. Probably we would have some way of generating a+ default originator (host info plus PID?) and a -o <originator>+ option to let us override it.++ We don't do stdin/out or network at the moment, because those can't+ be locked. Should we try to add some support for this? Or just leave+ that to other programs?++ In the long run, we should probably add an interactive mode (-i)+ which will let us do various kinds of manipulations.++-}++module LTR.Ttool (main) where++import Data.Binary (encode)+import Data.ByteString.Lazy.Char8 (pack)+import Data.Time.Clock (UTCTime, diffUTCTime)+import Data.Time.Format (readTime)+import LTR.TextTrans (transToText, textTransactionsParser)+import LTR.Transaction+import System.Console.GetOpt+import System.Environment (getArgs)+import System.Locale (defaultTimeLocale)+import Text.ParserCombinators.Parsec (parse)+import qualified Data.ByteString.Lazy as B++----------------------------------------------------------------------++data Command+ = AppendCommand FilePath Int Int [Flag] -- file app type flags+ | DumpCommand FilePath [Flag]+ | UndumpCommand FilePath+ | CommandError String+ deriving Show++data Flag+ = TransData String+ | TransDataFile String+ | TransTimestamp String+ deriving (Show)++options :: [OptDescr Flag]+options =+ [ Option ['d'] [] (ReqArg (\s -> TransData s) "DATA")+ "transaction data"+ , Option ['f'] [] (ReqArg (\s -> TransDataFile s) "FILE")+ "FILE containing transaction data"+ , Option ['t'] [] (ReqArg (\s -> TransTimestamp s) "TS")+ "timestamp, in milliseconds since the epoch."+ ]++parseCommandLine :: [String] -> Command+parseCommandLine argv =+ case getOpt Permute options argv of+ (flags, "append":path:app:ttype:[], [])+ -> AppendCommand path (read app) (read ttype) flags+ (flags, "dump":path:[], []) -> DumpCommand path flags+ (_, "undump":path:[], []) -> UndumpCommand path+ err -> CommandError (show err)++append path app ttype writeData =+ do+ putStrLn $ "writing :" ++ show trans ++ "\n\n" + appendTransaction path trans+ where + tempOriginator = mkOriginator 0 + oneMinute = readTime defaultTimeLocale "%M" "01" :: UTCTime + epoch = readTime defaultTimeLocale "" "" :: UTCTime+ tempTimeStamp = oneMinute `diffUTCTime` epoch+ trans = mkTransaction + (fromIntegral app) + (fromIntegral ttype) + tempOriginator + tempTimeStamp + writeData++dump :: FilePath -> IO ()+dump path = getTransactions path >>= mapM_ (putStr.transToText)++undump :: FilePath -> IO ()+undump path =+ do input <- readFile path+ case parse textTransactionsParser path input of+ Left err -> error $ show err+ Right ts -> B.putStr $ B.concat $ map encode ts++usage :: String -> IO ()+usage msg = + error $ concat+ [ "Invalid arguments: ", msg, "\n\n"+ , "Usage: ttool append TFILE APP TYPE "+ , "(-d DATA | -f FILE) [-t TS] \n"+ , " ttool dump TFILE\n"+ ]++main :: IO ()+main =+ do argv <- getArgs+ case parseCommandLine argv of+ CommandError s -> usage s+ DumpCommand path _flags -> dump path + UndumpCommand path -> undump path+ AppendCommand path app ttype+ [TransData writeData] -> append path app ttype (pack writeData)+ AppendCommand path app ttype+ [TransDataFile file] -> B.readFile file >>=+ append path app ttype+ AppendCommand _ _ _ _ ->+ error "No transaction data or file given"
+ Mhailist.cabal view
@@ -0,0 +1,48 @@+Name: Mhailist+Version: 0.0+Synopsis: Haskell mailing list manager+Description: A mailing list manager written in pure Haskell.+Category: Network+License: BSD3+Author: Curt Sampson, Lars Kotthoff+Maintainer: cjs@cynic.net, lars@larsko.org+Stability: experimental+Build-type: Simple+Cabal-version: >=1.6+Tested-with: GHC==6.10+Extra-source-files: README, LTR/Ttool.hs++Flag Test+ Description: Enable tests.+ Default: False++Flag Warnings+ Description: Enable warnings.+ Default: False++Executable mhailist+ Main-is: Mhailist.hs+ Extensions: CPP+ Other-modules: Data.Digest.Pure.MD5, LTR.Transaction, Mhailist.Address,+ Mhailist.BuildMessage, Mhailist.Error, Mhailist.List,+ Mhailist.Message, Mhailist.Receive, Mhailist.Transaction,+ Util.String+ Build-depends: base < 4, process, directory, haskell98, filepath, mtl,+ bytestring, old-locale, time, binary+ if flag(Warnings)+ Ghc-options: -Wall++Executable Test+ Main-is: Test.hs+ Extensions: CPP+ if flag(Test)+ Other-modules: Data.Digest.Pure.MD5, LTR.Transaction, Mhailist.Address,+ Mhailist.BuildMessage, Mhailist.Error, Mhailist.List,+ Mhailist.Message, Mhailist.Receive, Mhailist.Transaction,+ Util.String, UnitTest+ Build-depends: base < 4, process, directory, haskell98, filepath, mtl,+ bytestring, old-locale, time, binary, HUnit+ Cpp-options: -D__TEST__+ Ghc-options: -fno-ignore-asserts -O0+ else+ Buildable: False
+ Mhailist.hs view
@@ -0,0 +1,6 @@+module Main+where++import qualified Mhailist.Receive as MH++main = MH.main
+ Mhailist/Address.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE CPP #-}+module Mhailist.Address (+ parseAddress, Address (..),+ (+@), (-@), isValid, email,+#ifdef __TEST__+ _testAddress,+#endif+) where++import Mhailist.Error++#ifdef __TEST__+import UnitTest+#endif++--------------------------------------------------------------------------------++data Address = Address String String -- user domain+ deriving Eq++instance Show Address where+ show (Address user domain) = user ++ "@" ++ domain++-- function to retrieve an email address if the implementation changes later+email :: Address -> String+email = show++(+@) :: [Address] -> Address -> [Address]+(+@) addresses address = addresses ++ [address]++(-@) :: [Address] -> Address -> [Address]+(-@) addresses address = filter (address /=) addresses++--------------------------------------------------------------------------------++parseAddress :: String -> HandlesError Address+parseAddress header =+ let (jlen,alen) = jalen header+ usr = takeWhile (/= '@') $ drop jlen header+ dmn = tail $ dropWhile (/= '@') $ take alen $ drop jlen header+ in "parseAddress: " +# isValid (Address usr dmn) >>= return++-- |From a string containing an address return the length of the+-- substring before the address and the length of the address itself.+-- XXX This does not deal with quoted double-quotes.+jalen :: String -> (Int, Int)+jalen "" = (0,0)+jalen ('"':xs) = jalenSkipUntil '"' xs+jalen ('(':xs) = jalenSkipUntil ')' xs+jalen ('\'':xs) = jalenSkipUntil '\'' xs+jalen ('@':xs) = (0, length (takeWhile isUserDomainChar xs) + 1)+jalen (x:xs) = let (jlen, alen) = jalen xs+ in jalenNew x jlen alen++jalenNew :: Char -> Int -> Int -> (Int, Int)+jalenNew x 0 alen | isUserDomainChar x = (0, alen + 1)+ | otherwise = (1, alen)+jalenNew _ jlen alen = (jlen + 1, alen)++jalenSkipUntil :: Char -> String -> (Int, Int)+jalenSkipUntil x xs = let (junk, rest) = span (/= x) xs+ (jlen, alen) = jalen $ tail rest+ in (jlen + (length junk) + 2, alen)++isUserDomainChar :: Char -> Bool+isUserDomainChar x = if x `elem` "@'()<>/\\\" \t\n\r"+ then False+ else True++--------------------------------------------------------------------------------++isValid :: Address -> HandlesError Address+isValid (Address "" _) = throwError "Invalid email address: empty user"+isValid (Address _ "") = throwError "Invalid email address: empty domain"+isValid addr@(Address user domain) =+ if (any (any (not . isUserDomainChar))) [user, domain]+ then throwError $ "Invalid email address: \"" ++ show addr ++ "\""+ else return addr++--------------------------------------------------------------------------------++#ifdef __TEST__+_testAddresses = [ "foo@bar.com"+ , "<foo@bar.com>"+ , "foo <foo@bar.com>"+ , "foo bar <foo@bar.com>"+ , "\"foo bar\" <foo@bar.com>"+ , "\"foo bar\" foo@bar.com"+ , "foo@bar.com (foo bar)"+ , "\"foo bar \"<foo@bar.com>"+ , "\"foo@baz.com\" <foo@bar.com>"+ , "'foo@baz.com' <foo@bar.com>"+ , "(foo@baz.com) <foo@bar.com>"+ ]++test_parseAddress = test $ map testParse _testAddresses+ where testParse x = parseAddress x ~?= Right (Address "foo" "bar.com")++test_operators = test+ [ [] +@ (Address "foo" "bar") + ~?= [(Address "foo" "bar")]+ , [(Address "bar" "foo")] +@ (Address "foo" "bar")+ ~?= [(Address "bar" "foo"), (Address "foo" "bar")]+ , [(Address "foo" "bar")] +@ (Address "foo" "bar")+ ~?= [(Address "foo" "bar"), (Address "foo" "bar")]+ , [] -@ (Address "foo" "bar")+ ~?= []+ , [(Address "foo" "bar")] -@ (Address "foo" "bar")+ ~?= []+ , [(Address "foo" "bar")] -@ (Address "bar" "foo")+ ~?= [(Address "foo" "bar")]+ , [(Address "foo" "bar"), (Address "bar" "foo")] -@ (Address "bar" "foo")+ ~?= [(Address "foo" "bar")]+ ]++_testAddress = runTests $ "Mhailist.Address" ~: test + [ test_parseAddress+ , test_operators+ , "isValid" ~: test+ [ "empty" ~: isValid (Address "" "")+ ~?= Left "Invalid email address: empty user"+ , "/" ~: isValid (Address "foo/" "bar")+ ~?= Left "Invalid email address: \"foo/@bar\""+ , "\\" ~: isValid (Address "foo\\" "bar")+ ~?= Left "Invalid email address: \"foo\\@bar\""+ , "\"" ~: isValid (Address "\"foo" "bar\"")+ ~?= Left "Invalid email address: \"\"foo@bar\"\""+ , "'" ~: isValid (Address "foo" "bar'")+ ~?= Left "Invalid email address: \"foo@bar'\""+ , "()" ~: isValid (Address "(foo" "bar)")+ ~?= Left "Invalid email address: \"(foo@bar)\""+ , "@" ~: isValid (Address "foo@" "bar")+ ~?= Left "Invalid email address: \"foo@@bar\""+ , "<>" ~: isValid (Address "<foo" "bar>")+ ~?= Left "Invalid email address: \"<foo@bar>\""+ , "valid" ~: isValid (Address "foo" "bar")+ ~?= Right (Address "foo" "bar")+ ]+ ]+#endif
+ Mhailist/BuildMessage.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE CPP #-}+module Mhailist.BuildMessage (+ Message (..), Header (..), mkHeader, parseMessage,+#ifdef __TEST__+ testMessage, _testBuildMessage,+#endif+) where++import Data.List (isPrefixOf)+import Data.Char (isSpace)++#ifdef __TEST__+import UnitTest+#endif++data Message = Message [Header] String+ deriving (Show, Eq)++data Header = Header String String+ deriving (Show, Eq)++-- XXX This needs to use the line-ending convention of the message, which+-- may be \r\n instead of just \n.+--+mkHeader :: String -> String -> Header+mkHeader name value = Header (concat [name, ": "]) (concat [value, "\n"])++--------------------------------------------------------------------------------++-- parseMessage takes a string containing a message as an argument and returns+-- the message data structure, consisting of a list of header lines and the+-- body.+-- Note that no termination characters are dropped; i.e. the separator between+-- header lines (linebreak) will be added to the header it terminates, the+-- separator between header name and value (colon) is part of the header value.+parseMessage :: String -> Message+parseMessage msg = dropFrom $ pm headerLengths msg+ where+ (headerLengths,_) = hlenboff (lineBreak msg) msg+ pm [] msg = Message [] msg+ pm (hl:hls) msg =+ let Message headers body = pm hls $ drop hl msg+ (name,value) = span (\c -> c /= ':') (take hl msg)+ in Message (Header name value : headers) body+ dropFrom msg@(Message (Header name _:headers) body) =+ if isPrefixOf "From " name then Message headers body+ else msg+ dropFrom m = m++-- hlenboff takes the break between header lines and the header and the+-- body of the message (the break twice) as the first argument and the message+-- to process as the second argument. Returned is a pair of a list of integers+-- and an integer. The list of integers designates the lengths of the header+-- lines -- the first element of the list is the length of the first header+-- line, the second header line can be found at the offset given by the length+-- of the first header line; its length is designated by the second element in+-- the list of integers and so on. The second element of the pair denotes the+-- offset of the message body into the message.+-- The length of the header lines includes the break between them; i.e. if+-- header lines are terminated by "\r\n", the character at the end of a header+-- line is the '\n' of the "\r\n".+hlenboff :: String -> String -> ([Int], Int) -- lens, bodyOffset+hlenboff lb msg = hlb lb msg+ where++ hlb _ [] = ([0], 0)++ hlb lb msg | (lb++lb) `isPrefixOf` msg = ([length lb], length lb)++ hlb lb msg@(_:ms) | lb `isPrefixOf` msg+ && startsWithWhiteSpace (drop (length lb) msg) =+ let ((hl:hls),mo) = hlb lb ms+ in (hl + 1 : hls, mo + 1)++ hlb lb msg | lb `isPrefixOf` msg =+ let (hls,mo) = hlb lb (drop (length lb) msg)+ in (length lb : hls, mo + length lb)++ hlb lb (_:ms) =+ let ((hl:hls),mo) = hlb lb ms+ in (hl + 1 : hls, mo + 1)++ startsWithWhiteSpace (c:_) = isSpace c+ startsWithWhiteSpace _ = False++-- lineBreak takes a string as an argument and returns the first linebreak+-- sequence (one of "\r\n", "\n", "\r") encountered, or the empty string if the+-- input does not contain a linebreak sequence.+lineBreak :: String -> String+lineBreak "" = ""+lineBreak ('\r':'\n':_) = "\r\n"+lineBreak ('\n':_) = "\n"+lineBreak ('\r':_) = "\r"+lineBreak (_:cs) = lineBreak cs++--------------------------------------------------------------------------------++#ifdef __TEST__+testMessageInput = unlines $+ [ "From joe@example.com on somedate"+ , "X-Original-To: mylist@lists.com"+ , "From: foo@bar.com"+ , "Continued: more "+ , "\t data here"+ , "Subject: \t Fubar\r\n"+ , "This is a message. Ha ha!\nHa ha!"+ ]++testMessage = Message+ [ Header "X-Original-To" ": mylist@lists.com\n"+ , Header "From" ": foo@bar.com\n"+ , Header "Continued" ": more \n\t data here\n"+ , Header "Subject" ": \t Fubar\r\n"+ ] "\nThis is a message. Ha ha!\nHa ha!\n"++test_parseMessage = test+ [ parseMessage testMessageInput ~?= testMessage+ , parseMessage "A: foo\r\nB:bar\r\n\r\nCCC" ~?=+ Message [Header "A" ": foo\r\n", Header "B" ":bar\r\n"] "\r\nCCC"+ ]++test_hlenboff = test+ [ hlenboff lb "" ~?= ( [0], 0 )+ , hlenboff lb "abc" ~?= ( [3], 3 )+ , hlenboff lb "ab()c()()ef()()gh" ~?= ( [4,3], 7 )+ ]+ where lb = "()"++test_lineBreak = test+ [ "" ~=? lineBreak ""+ , "\n" ~=? lineBreak "\n"+ , "\r" ~=? lineBreak "abc\rdef\n"+ , "\n" ~=? lineBreak "abc\ndef\r\n\n\r"+ , "\r\n" ~=? lineBreak "abc\r\ndef\r\n"+ ]++_testBuildMessage = runTests $ "Mhailist.BuildMessage" ~: test + [ test_lineBreak+ , test_hlenboff+ , test_parseMessage+ ]+#endif
+ Mhailist/Error.hs view
@@ -0,0 +1,20 @@+module Mhailist.Error (+ HandlesError,+ liftError,+ throwError, (+#),+ ErrorT, runErrorT, liftIO,+) where++import Control.Monad.Error++type HandlesError = Either String++liftError :: (Error l, Monad m) => Either l r -> ErrorT l m r+liftError f = case f of+ Left err -> throwError err+ Right val -> return val++(+#) :: String -> HandlesError b -> HandlesError b+(+#) msg cmp = case cmp of+ Left err -> throwError $ msg ++ err+ Right v -> return v
+ Mhailist/List.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE CPP, NamedFieldPuns #-}++module Mhailist.List (+ List (..), ListAction (..), mkList, listAddress, listID,+#ifdef __TEST__+ _testList,+#endif+) where++import Mhailist.Message (Message, Address (..), envelopeRecipient)+import Mhailist.Error++#ifdef __TEST__+import UnitTest+#endif++import System.FilePath (combine)++----------------------------------------------------------------------++data List = List+ { listName :: String+ , listDomain :: String+ , listAddrFile :: FilePath+ } deriving (Show, Eq)++data ListAction+ = SendToList+ | Subscribe+ | Unsubscribe+ deriving (Show, Eq)++mkList :: FilePath -> Message -> HandlesError (List,ListAction)+mkList listFileDir message = "mkList: " +#+ do recipient <- envelopeRecipient message+ listAndAction <- mkListFromAddr listFileDir recipient+ return listAndAction++mkListFromAddr :: FilePath -> Address -> HandlesError (List,ListAction)+mkListFromAddr listFileDir (Address user domain) = "mkListFromAddr: " +#+ do let (name,action) = getAction user+ return (List name domain+ (combine listFileDir $ concat [name, '@':domain])+ ,action)++----------------------------------------------------------------------++getAction :: String -> (String,ListAction)+getAction (x:"-subscribe") = (x:[], Subscribe)+getAction (x:"-unsubscribe") = (x:[], Unsubscribe)+getAction (x:xs) = let (id, action) = getAction xs+ in (x:id, action)+getAction [] = ([], SendToList)++----------------------------------------------------------------------++listAddress :: List -> Address+listAddress list = Address (listName list) (listDomain list)++listID :: List -> String+listID List{listName,listDomain} = concat [listName, "@", listDomain]++----------------------------------------------------------------------++#ifdef __TEST__+testList = List "f" "b" (combine "/x" "f@b")++_testList = runTests $ "Mhailist.List" ~: test + [ "getAction empty" ~: getAction "" ~?= ("", SendToList)+ , "getAction no action" ~: getAction "foo" ~?= ("foo", SendToList)+ , "getAction subscribe" ~: getAction "foo-subscribe" ~?= ("foo", Subscribe)+ , "getAction unsub" ~: getAction "foo-unsubscribe" ~?= ("foo", Unsubscribe)+ , "mkList list" ~: mkListFromAddr "/x" (Address "f" "b")+ ~?= Right (testList, SendToList)+ , "mkList action sub" ~: mkListFromAddr "/x" (Address "f-subscribe" "b")+ ~?= Right (testList, Subscribe)+ , "mkList action unsub" ~: mkListFromAddr "/x" (Address "f-unsubscribe" "b")+ ~?= Right (testList, Unsubscribe)+ , "listAddress" ~: listAddress testList ~?= Address "f" "b"+ ]+#endif
+ Mhailist/Message.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE CPP #-}+module Mhailist.Message (+ Message, parseMessage, mkMessage, addHeader,+ rfc2822Format, parseAddress,+ envelopeRecipient, fromAddress,+ Address (..), (+@), (-@),+#ifdef __TEST__+ _testMessage,+#endif+) where++import Mhailist.BuildMessage+import Mhailist.Address+import Mhailist.Error++#ifdef __TEST__+import UnitTest+#endif++import Data.Char (isSpace, toLower)++--------------------------------------------------------------------------------++headers :: String -> Message -> [String]+headers name (Message headers _) =+ map value matching+ where+ matching = filter matchName headers+ matchName (Header n _) = lower name == (lower . trimWhiteSpace) n+ value (Header _ (':':v)) = trimWhiteSpace v+ value _ = error "headers: bad value"+ lower = map toLower++header :: String -> Message -> HandlesError String+header name msg = do case headers name msg of+ [] -> throwError $ "Header " ++ show name+ ++ " not found"+ (v:[]) -> return v+ (_:_) -> throwError $ "Expected one header"+ ++ show name+ ++ ", but got several"++rfc2822Format :: Message -> String+rfc2822Format (Message headers body) =+ concat $ (map headerLine headers) ++ [body]+ where+ headerLine (Header name value) = name ++ value++--------------------------------------------------------------------------------++addressFromHeader :: Message -> String -> HandlesError Address+addressFromHeader msg hdr = "addressFromHeader: " +#+ header hdr msg >>= parseAddress >>= return++envelopeRecipient :: Message -> HandlesError Address+envelopeRecipient msg = "envelopeRecipient: " +#+ addressFromHeader msg "x-original-to"++fromAddress :: Message -> HandlesError Address+fromAddress msg = "fromAddress: " +# addressFromHeader msg "From"++--------------------------------------------------------------------------------++trimWhiteSpace :: String -> String+trimWhiteSpace = let t = reverse . dropWhile isSpace+ in t.t++--------------------------------------------------------------------------------++mkMessage :: Address -> Address -> String -> String -> Message+mkMessage from to subject body =+ let headerNames = [ "From", "To", "Subject" ]+ headerValues = map (\x -> ": " ++ x ++ "\r\n")+ [ show from, show to, subject ]+ in Message (map (\x -> Header (fst x) (snd x))+ (zip headerNames headerValues))+ ("\r\n" ++ body)++addHeader :: Header -> Message -> Message+addHeader header (Message headers body) = Message (header:headers) body++--------------------------------------------------------------------------------++#ifdef __TEST__+test_headers = test+ [ headers "continued" testMessage ~?= ["more \n\t data here"]+ , headers "hahaha" testMessage ~?= []+ ]++test_mkMessage = test+ [ mkMessage (Address "me" "here") (Address "you" "there")+ "test" "foobar" ~?=+ Message+ [ Header "From" ": me@here\r\n"+ , Header "To" ": you@there\r\n"+ , Header "Subject" ": test\r\n"+ ] "\r\nfoobar"+ ]++_testMessage = runTests $ "Mhailist.Message" ~: test + [ test_headers+ , test_mkMessage+ , envelopeRecipient testMessage ~?= Right (Address "mylist" "lists.com")+ , fromAddress testMessage ~?= Right (Address "foo" "bar.com")+ , "trimWhiteSpace" ~: test+ [ "empty" ~: trimWhiteSpace "" ~?= ""+ , "none" ~: trimWhiteSpace "foo" ~?= "foo"+ , "start" ~: trimWhiteSpace " foo" ~?= "foo"+ , "end" ~: trimWhiteSpace "foo " ~?= "foo"+ , "start/end" ~: trimWhiteSpace " foo " ~?= "foo"+ , "tab" ~: trimWhiteSpace "\tfoo" ~?= "foo"+ , "only" ~: trimWhiteSpace " \t\n\r" ~?= ""+ , "middle" ~: trimWhiteSpace "f oo" ~?= "f oo"+ ]+ ]+#endif
+ Mhailist/Receive.hs view
@@ -0,0 +1,96 @@+-- +-- mhailist-receive - process mail for the list+--+-- Usage: mhailist-receive <list-file-dir> <sendmail-path>+--+-- This program expects the mail to be processed to be passed to it on STDIN.+--+-- Messages to listname-command@listdomain execute a command on+-- listname@listdomain for the sender of the message; commands understood+-- are "subscribe" and "unsubscribe".+--+-- Otherwise, messages to listname@listdomain are forwarded to the list+-- if the sender is subscribed to the list. If the list doesn't exist+-- we print an error and exit with an error code.+--+-- The list of subscribed addresses is stored in a file named+-- listname@listdomain in the directory given as the <list-file-dir>+-- command line argument.+--+-- Bugs:+--+--++module Mhailist.Receive (main) where++import Mhailist.Address+import Mhailist.BuildMessage (mkHeader)+import Mhailist.Error+import Mhailist.List+import Mhailist.Message+import Mhailist.Transaction++import Control.Concurrent+import Data.List+import Monad+import System+import System.Directory+import System.IO+import System.Process+++----------------------------------------------------------------------++main :: IO ()+main = do result <- runErrorT processMessage+ case result of+ Left err -> error err+ Right () -> return ()++processMessage :: ErrorT String IO ()+processMessage =+ do [listFileDir, sendmailPath] <- liftIO getArgs+ input <- liftIO getContents+ let message = parseMessage input+ (list,action) <- liftError $ mkList listFileDir message+ from <- liftError $ fromAddress message+ let addrFile = listAddrFile list+ assertFileExists $! addrFile+ addresses <- subscribers addrFile+ liftIO $ updateSubscribers addrFile action from+ let listAddr = (listAddress list)+ listIDHeader = mkHeader "List-Id" (listID list)+ (addressees, msg) <- return $+ case action of+ SendToList -> (addresses, addHeader listIDHeader message)+ Subscribe -> ([from], mkMessage listAddr from+ "Subscription confirmation"+ "As of now, you are subscribed.")+ Unsubscribe -> ([from], mkMessage listAddr from+ "Unsubscription confirmation"+ "As of now, you are unsubscribed.")+ liftIO $ sendMail sendmailPath addressees (rfc2822Format msg)+ where+ assertFileExists path = do x <- liftIO $ doesFileExist path+ unless x $ throwError "no list ID found"++sendMail :: FilePath -> [Address] -> String -> IO ()+sendMail cmd addresses mail = do+ (pin, pout, perr, procHandle) <- runInteractiveProcess+ cmd -- command+ (map email addresses) -- arguments+ Nothing Nothing -- cwd, env+ waitIn <- alertWhenFinished (hPutStr pin mail >> hClose pin)+ waitOut <- alertWhenFinished (putStr =<< hGetContents pout)+ waitErr <- alertWhenFinished (putStr =<< hGetContents perr)+ mapM_ takeMVar [waitIn, waitOut, waitErr]+ status <- waitForProcess procHandle+ case status of+ ExitSuccess -> return ()+ ExitFailure n -> error $ cmd ++ " failed with status " ++ show n++alertWhenFinished :: IO () -> IO (MVar ())+alertWhenFinished cmds =+ do done <- newEmptyMVar+ forkIO (cmds >> putMVar done ())+ return done
+ Mhailist/Transaction.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE NamedFieldPuns #-}++module Mhailist.Transaction (+ updateSubscribers, subscribers+) where++import Control.Monad (liftM)+import Control.Monad.Error (ErrorT)+import Control.Monad.Trans (liftIO)+import Data.ByteString.Lazy.Char8 (pack,unpack)+import Data.List (nub)+import Data.Time.Clock.POSIX (getPOSIXTime)++import LTR.Transaction++import Mhailist.Address (Address,parseAddress)+import Mhailist.Error (liftError)+import Mhailist.List (ListAction (..))++--------------------------------------------------------------------------------++app = 42++ttype Subscribe = 0+ttype Unsubscribe = 1+ttype _ = error "invalid transaction type"++--------------------------------------------------------------------------------++updateSubscribers :: FilePath -> ListAction -> Address -> IO ()+updateSubscribers _ SendToList _ = return ()+updateSubscribers path action address =+ do+ time <- getPOSIXTime+ appendTransaction path (trans time)+ where + trans time = mkTransaction (fromIntegral app)+ (fromIntegral $ ttype action) + (mkOriginator 0) time+ (pack $ show address)++subscribers :: FilePath -> ErrorT String IO [Address]+subscribers path =+ do ts <- liftIO $ getTransactions path+ let subsData = map getData $ getSubscribed [] $! ts+ addresses = mapM (liftError . parseAddress . unpack) subsData+ in liftM nub addresses+ where+ -- XXX: check for invalid transactions+ getSubscribed subs [] = subs+ getSubscribed subs ((InvalidTransaction _):ts) =+ getSubscribed subs ts+ getSubscribed subs (t@Transaction{transType}:ts)+ | transType == ttype Subscribe = getSubscribed (t:subs) ts+ | otherwise = getSubscribed+ (removeEarlier t subs) ts+ removeEarlier _ [] = []+ removeEarlier unsub@(Transaction _ _ _ uTime uData _ _)+ (t@(Transaction _ _ _ sTime sData _ _):ts)+ | uData == sData && sTime < uTime = removeEarlier unsub ts+ | otherwise =+ t:(removeEarlier unsub ts)+ removeEarlier _ _ = []+ getData Transaction{transData} = transData+ getData (InvalidTransaction _) =+ error "Can't get data from invalid transaction"
+ README view
@@ -0,0 +1,19 @@+This is very much work in progress and an alpha development release.++Call the main program from whatever you are using to receive mail.++Usage: mhailist <list-file-dir> <sendmail-path>++This program expects the mail to be processed to be passed to it on STDIN.++Messages to listname-command@listdomain execute a command on+listname@listdomain for the sender of the message; commands understood+are "subscribe" and "unsubscribe".++Otherwise, messages to listname@listdomain are forwarded to the list+if the sender is subscribed to the list. If the list doesn't exist+we print an error and exit with an error code.++The list of subscribed addresses is stored in a file named+listname@listdomain in the directory given as the <list-file-dir>+command line argument.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ Test.hs view
@@ -0,0 +1,18 @@+module Main+where++import LTR.Transaction (_testTransaction)+import Mhailist.BuildMessage (_testBuildMessage)+import Mhailist.Address (_testAddress)+import Mhailist.List (_testList)+import Mhailist.Message (_testMessage)+import Util.String (_testString)+import UnitTest (_unitTest)++main = do _testTransaction+ _testBuildMessage+ _testAddress+ _testList+ _testMessage+ _testString+ _unitTest
+ UnitTest.hs view
@@ -0,0 +1,102 @@+{-# OPTIONS_GHC #-}+module UnitTest (++ runTests,+ approximate, approx, approxE,+ (@?~=), (~?~=),++ -- From Test.HUnit+ Test (..),+ test, (~?=), (~=?),+ assertEqual, (@=?),+ (~:),++ -- * Debugging assistance+ module Debug.Trace,++ _unitTest,++) where++import Debug.Trace+import Numeric (floatToDigits)+import System.Exit+import Test.HUnit++------------------------------------------------------------++runTests :: Test -> IO Counts+runTests = runTestTT++------------------------------------------------------------++{-+01:22 <quicksilver> it could be in some lib on hackage, though.+01:23 <quicksilver> you could knock up some funky syntax so you could write:+01:23 <quicksilver> (x + y - z) =~= Tolerance 0.0001 6.315+01:23 <quicksilver> and then define "around = Tolerance 0.000001"+01:23 <quicksilver> to write+01:23 <quicksilver> (x+y-z) =~= around 6.315+-}++---------++data Approximation = Approximation ([Int], Int)+ deriving (Show, Read, Eq)++-- | Produce an approximation of n to the given number of significant digits.+approximate :: RealFloat n => Int -> n -> Approximation+approximate significant n =+ let (digits, exponent) = (floatToDigits 10 n)+ (sigdigs, rest) = splitAt significant $ digits ++ repeat 0+ (most, last) = splitAt (significant - 1) sigdigs+ in if head rest < 5+ then Approximation (sigdigs, exponent)+ else Approximation (most ++ [(head last + 1)], exponent)++-- | Produce an approximation of n to the number of significant digits in n.+approx :: RealFloat n => n -> Approximation+approx n = Approximation (floatToDigits 10 n)++-- | Produce an approximation of n to the number of significant digits in n,+-- but scaled with the given exponent.+approxE :: RealFloat n => n -> Int -> Approximation+approxE m exp = Approximation (digits, exp)+ where (digits, _) = (floatToDigits 10 m)++sigdigs :: Approximation -> Int+sigdigs (Approximation (digits, _)) = length digits++infix 1 @?~=, ~?~=++-- | Assert that the RealFloat on the left is the same as the approximation+-- on the right, to the accuracy of the approximation.+--+(@?~=) :: (RealFloat n) => n -> Approximation -> Assertion+actual @?~= expected =+ let actualSigdigs = approximate (sigdigs expected) actual+ in actualSigdigs == expected @?+ "Expected: " ++ (show expected) ++ " Actual: " ++ (show actualSigdigs)++-- | Create a Test to verify that the RealFloat on the left is equal to the+-- Approximation on the right, to the approximation's number of significant+-- digits. The approxmation is usually created with approx or approxE.+--+(~?~=) :: (RealFloat n) => n -> Approximation -> Test+actual ~?~= expected = TestCase (actual @?~= expected)++---------++_unitTest = runTests $ test+ [ "approx_long" ~: approximate 3 3.14159 ~?= Approximation ([3,1,4], 1)+ , "approx_short" ~: approximate 5 7 ~?= Approximation ([7,0,0,0,0], 1)+ , "approx_exp" ~: approximate 4 8890123 ~?= Approximation ([8,8,9,0], 7)+ , "approx_round" ~: approximate 4 1.2345 ~?= Approximation ([1,2,3,5], 1)+ , "approx_1a" ~: approx 3 ~?= Approximation ([3], 1)+ , "approx_1b" ~: approx 300 ~?= Approximation ([3], 3)+ , "approx_negex" ~: approx 0.00378 ~?= Approximation ([3, 7, 8], -2)+ , "approx_small" ~: approxE 2.1 (-3) ~?= Approximation ([2, 1], -3)+ , "approx_eq_1" ~: 3.141592654 ~?~= approx 3+ , "approx_round" ~: 3.141592654 ~?~= approx 3.142+ ]+
+ Util/String.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE CPP #-}++module Util.String (+ split,+#ifdef __TEST__+ _testString,+#endif+) where++#ifdef __TEST__+import UnitTest+#endif++#if __GLASGOW_HASKELL__ <= 608+import Data.String+import qualified Data.ByteString.Char8 as SB+import qualified Data.ByteString.Lazy.Char8 as LB+#endif++----------------------------------------------------------------------+-- String Overloading++-- You must add add the following pragma to files that use this:+-- {-# LANGUAGE OverloadedStrings #-}++#if __GLASGOW_HASKELL__ <= 608+instance IsString SB.ByteString where fromString = SB.pack+instance IsString LB.ByteString where fromString = LB.pack+#endif++----------------------------------------------------------------------++-- | Same as 'Data.ByteString.split'.+--+split :: (Eq a) => a -> [a] -> [[a]]+split c s = reverse $ split' c s [[]]+ where+ split' _ [] (p:ps) = (reverse p:ps)+ split' c (s:ss) (p:ps)+ | c == s = split' c ss ([]:reverse p:ps)+ | otherwise = split' c ss ((s:p):ps)+ split' _ _ [] = error "Util.String.split: can't arrive here."++----------------------------------------------------------------------++#ifdef __TEST__+_testString = runTests $ "Util.String" ~: test+ [ split ',' "" ~?= [""]+ , split ',' "ab" ~?= ["ab"]+ , split ',' "ab,cd,ef" ~?= ["ab","cd","ef"]+ , split ',' ",ab," ~?= ["","ab", ""]+ ]+#endif