diff --git a/Data/Digest/Pure/MD5.hs b/Data/Digest/Pure/MD5.hs new file mode 100644 --- /dev/null +++ b/Data/Digest/Pure/MD5.hs @@ -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 diff --git a/LTR/Transaction.hs b/LTR/Transaction.hs new file mode 100644 --- /dev/null +++ b/LTR/Transaction.hs @@ -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 diff --git a/LTR/Ttool.hs b/LTR/Ttool.hs new file mode 100644 --- /dev/null +++ b/LTR/Ttool.hs @@ -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 + 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" diff --git a/Mhailist.cabal b/Mhailist.cabal new file mode 100644 --- /dev/null +++ b/Mhailist.cabal @@ -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 diff --git a/Mhailist.hs b/Mhailist.hs new file mode 100644 --- /dev/null +++ b/Mhailist.hs @@ -0,0 +1,6 @@ +module Main +where + +import qualified Mhailist.Receive as MH + +main = MH.main diff --git a/Mhailist/Address.hs b/Mhailist/Address.hs new file mode 100644 --- /dev/null +++ b/Mhailist/Address.hs @@ -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 " + , "foo bar " + , "\"foo bar\" " + , "\"foo bar\" foo@bar.com" + , "foo@bar.com (foo bar)" + , "\"foo bar \"" + , "\"foo@baz.com\" " + , "'foo@baz.com' " + , "(foo@baz.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 "") + ~?= Left "Invalid email address: \"\"" + , "valid" ~: isValid (Address "foo" "bar") + ~?= Right (Address "foo" "bar") + ] + ] +#endif diff --git a/Mhailist/BuildMessage.hs b/Mhailist/BuildMessage.hs new file mode 100644 --- /dev/null +++ b/Mhailist/BuildMessage.hs @@ -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 diff --git a/Mhailist/Error.hs b/Mhailist/Error.hs new file mode 100644 --- /dev/null +++ b/Mhailist/Error.hs @@ -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 diff --git a/Mhailist/List.hs b/Mhailist/List.hs new file mode 100644 --- /dev/null +++ b/Mhailist/List.hs @@ -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 diff --git a/Mhailist/Message.hs b/Mhailist/Message.hs new file mode 100644 --- /dev/null +++ b/Mhailist/Message.hs @@ -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 diff --git a/Mhailist/Receive.hs b/Mhailist/Receive.hs new file mode 100644 --- /dev/null +++ b/Mhailist/Receive.hs @@ -0,0 +1,96 @@ +-- +-- mhailist-receive - process mail for the list +-- +-- Usage: mhailist-receive +-- +-- 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 +-- 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 diff --git a/Mhailist/Transaction.hs b/Mhailist/Transaction.hs new file mode 100644 --- /dev/null +++ b/Mhailist/Transaction.hs @@ -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" diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 + +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 +command line argument. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/Test.hs b/Test.hs new file mode 100644 --- /dev/null +++ b/Test.hs @@ -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 diff --git a/UnitTest.hs b/UnitTest.hs new file mode 100644 --- /dev/null +++ b/UnitTest.hs @@ -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 it could be in some lib on hackage, though. +01:23 you could knock up some funky syntax so you could write: +01:23 (x + y - z) =~= Tolerance 0.0001 6.315 +01:23 and then define "around = Tolerance 0.000001" +01:23 to write +01:23 (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 + ] + diff --git a/Util/String.hs b/Util/String.hs new file mode 100644 --- /dev/null +++ b/Util/String.hs @@ -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