diff --git a/Codec/Mbox.hs b/Codec/Mbox.hs new file mode 100644 --- /dev/null +++ b/Codec/Mbox.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE BangPatterns, TypeOperators, TemplateHaskell #-} +-------------------------------------------------------------------- +-- | +-- Module : Codec.Mbox +-- Copyright : (c) Nicolas Pouillard 2008, 2009 +-- License : BSD3 +-- +-- Maintainer: Nicolas Pouillard +-- Stability : provisional +-- Portability: +-- +-------------------------------------------------------------------- + +module Codec.Mbox + ( + -- * Mailbox, message, and direction data types + Mbox(..) + , MboxMessage(..) + , Direction(..) + + -- * Mailbox parsing functions + , parseMboxFile + , parseMboxFiles + , parseMbox + , safeParseMbox + , parseOneMboxMessage + + -- * Mailbox printing functions + , showMbox + , showMboxMessage + , showMboxFromLine + + -- * First-class labels + , mboxMsgSender + , mboxMsgTime + , mboxMsgBody + , mboxMsgFile + , mboxMsgOffset + + -- * Misc + , Month(..) + , fromQuoting + , msgYear + , msgMonthYear + , opposite + ) where + +import Control.Arrow (first,second) +import Control.Applicative ((<$>)) +import qualified Data.ByteString.Lazy.Char8 as C -- Char8 interface over Lazy ByteString's +import Data.Label +import Data.ByteString.Lazy (ByteString) +import Data.Int (Int64) +import Data.Maybe (listToMaybe) +import System.IO +import System.IO.Unsafe (unsafeInterleaveIO) + +data a :*: b = !a :*: !b + +first' :: (a -> b) -> (a :*: c) -> (b :*: c) +first' f !(a :*: c) = f a :*: c +{-# INLINE first' #-} +uncurry' :: (a -> b -> c) -> a :*: b -> c +uncurry' f (x :*: y) = f x y +{-# INLINE uncurry' #-} + +--import Test.QuickCheck + +-- | An 'Mbox' is a list of 'MboxMessage' +newtype Mbox s = Mbox { mboxMessages :: [MboxMessage s] } + deriving (Eq, Ord, Show) + +-- | An 'MboxMessage' represent an mbox message, featuring +-- the sender, the date-time, and the message body. +data MboxMessage s = MboxMessage { _mboxMsgSender :: s + , _mboxMsgTime :: s + , _mboxMsgBody :: s + , _mboxMsgFile :: FilePath + , _mboxMsgOffset :: Int64 } + deriving (Eq, Ord, Show) + +$(mkLabelsNoTypes [''MboxMessage]) + +-- | First-class label to message's sender +mboxMsgSender :: MboxMessage s :-> s + +-- | First-class label to the date and time of the given message +mboxMsgTime :: MboxMessage s :-> s + +-- | First-class label to message's raw body +mboxMsgBody :: MboxMessage s :-> s + +-- | First-class label to the file path of mbox's message +mboxMsgFile :: MboxMessage s :-> FilePath + +-- | First-class label to the offset of the given message into the mbox +mboxMsgOffset :: MboxMessage s :-> Int64 + +readYear :: MboxMessage C.ByteString -> C.ByteString -> Int +readYear m s = + case reads $ C.unpack s of + [(i, "")] -> i + _ -> error ("readYear: badly formatted date (year) in " ++ show (C.unpack $ _mboxMsgTime m)) + +data Month = Jan + | Feb + | Mar + | Apr + | May + | Jun + | Jul + | Aug + | Sep + | Oct + | Nov + | Dec + deriving (Read, Show, Eq) + +readMonth :: MboxMessage C.ByteString -> C.ByteString -> Month +readMonth m s = + case reads $ C.unpack s of + [(month, "")] -> month + _ -> error ("readMonth: badly formatted date (month) in " ++ show (C.unpack $ _mboxMsgTime m)) + +msgYear :: MboxMessage C.ByteString -> Int +msgYear m = readYear m . last . C.split ' ' . _mboxMsgTime $ m + +msgMonthYear :: MboxMessage C.ByteString -> (Month,Int) +msgMonthYear m = + case filter (not . C.null) . C.split ' ' . _mboxMsgTime $ m of + [_wday, month, _mday, _hour, year] -> (readMonth m month, readYear m year) + _ -> error ("msgMonthYear: badly formatted date in " ++ show (C.unpack $ _mboxMsgTime m)) + +nextFrom :: ByteString -> Maybe (Int64, ByteString, ByteString) +nextFrom !orig = goNextFrom 0 orig + where goNextFrom !count !input = do + off <- (+1) <$> C.elemIndex '\n' input + let (nls, i') = first C.length $ C.span (=='\n') $ C.drop off input + if C.take 5 i' == bFrom + then let off' = off + count + (nls - 1) in + Just (off', C.take off' orig, C.drop 5 i') + else goNextFrom (off + count + nls) i' + +-- TODO rules: +-- - fromQuoting id == id +-- - f . g == id ==> fromQuoting f . fromQuoting g == id +-- but fromQuoting can fail on negative levels +-- special case that works: +-- n > 0 ==> fromQuoting ((-)n) . fromQuoting (+n) == id + +-- TODO performances: +-- This ByteString fromQuoting is already quite fast, +-- It still implies a x2 factor to the mbox-average-size tool, wether one +-- enables it or not. +-- Perhaps fusing nextFrom and fromQuoting could give more performances +-- (but will decrease performances of mbox-counting). + +-- | @fromQuoting f s@ returns @s@ where the quoting level +-- of From_ lines has been updated using the @f@ function. +-- +-- The From_ spefication, quoted from : +-- +-- @ +-- \>From quoting ensures that the resulting +-- lines are not From_ lines: the program prepends a \> to any +-- From_ line, \>\From_ line, \>\>From_ line, \>\>\>From_ line, etc. +-- @ +fromQuoting :: (Int64 -> Int64) -> C.ByteString -> C.ByteString +fromQuoting onLevel = C.tail . nextQuotedFrom . C.cons '\n' + where nextQuotedFrom !orig = goNextQuotedFrom 0 orig + where goNextQuotedFrom !count !input = + case C.elemIndex '\n' input of + Nothing -> + -- TODO,NOTE: here I don't know what to do between the + -- following code and just returning `orig' + if C.null input then orig else orig `C.snoc` '\n' + Just off -> + let (!level, i') = first C.length $ C.span (=='>') $ C.drop (off + 1) input in + if C.take 5 i' == bFrom + then C.take (off + count) orig `C.append` + mkQuotedFrom (onLevel level) `C.append` + nextQuotedFrom (C.drop 5 i') + else goNextQuotedFrom (off + level + count + 1) i' + +{- +prop_fromQuotingInv (NonNegative n) s = s == fromQuoting (+(-n)) (fromQuoting (+n) s) +prop_unparse_parse m = either (const False) (==m) $ safeParseMbox (showMbox m) +prop_parse_unparse m = let s = showMbox m in Right s == (showMbox <$> safeParseMbox s) + +-- | Prefered xs: have the xs elements as favorites. +newtype Prefered a = Prefered { unPrefered :: a } + deriving ( Eq, Ord, Show, Read ) + +class Favorites a where + favorites :: [a] + +instance Favorites Char where + favorites = ">From \n" + +instance Arbitrary C.ByteString where + arbitrary = arbitrary >>= return . C.pack . map unPrefered + +instance (Favorites a, Arbitrary a) => Arbitrary (Prefered a) where + arbitrary = + frequency + [ (2, Prefered `fmap` oneof (map return favorites)) + , (1, Prefered `fmap` arbitrary) + ] + + shrink (Prefered x) = Prefered `fmap` shrink x + +--instance Arbitrary s => Arbitrary (MboxMessage s) where +instance Arbitrary (MboxMessage ByteString) where + arbitrary = MboxMessage (C.pack "S") (C.pack "D") <$> arbitrary -- TODO better sender,time + shrink (MboxMessage x y z) = [ MboxMessage x' y' z' | (x', y', z') <- shrink (x, y, z) ] + +instance Arbitrary (Mbox ByteString) where +--instance Arbitrary s => Arbitrary (Mbox s) where + arbitrary = Mbox <$> arbitrary + shrink (Mbox x) = Mbox <$> shrink x +-} + +mkQuotedFrom :: Int64 -> C.ByteString +mkQuotedFrom n | n < 0 = error "mkQuotedFrom: negative quoting" + | otherwise = '\n' `C.cons` C.replicate n '>' `C.append` bFrom + + +bFrom :: ByteString +bFrom = C.pack "From " + +skipFirstFrom :: ByteString -> Either String ByteString +skipFirstFrom xs | bFrom == C.take 5 xs = Right $ C.drop 5 xs + | otherwise = Left "skipFirstFrom: badly formatted mbox: 'From ' expected at the beginning" + +-- | Same as 'parseMbox' but cat returns an error message. +-- However only the line can cause an error message currently, so it's fine +-- to dispatch on the either result. +safeParseMbox :: FilePath -> Int64 -> ByteString -> Either String (Mbox ByteString) +safeParseMbox fp offset s | C.null s = Right $ Mbox [] + | otherwise = Mbox . map (uncurry' $ finishMboxMessageParsing fp) . splitMboxMessages offset + <$> skipFirstFrom s + +-- | Turns a 'ByteString' into an 'Mbox' by splitting on From_ lines and +-- unquoting the \'\>\*From\'s of the message. +parseMbox :: ByteString -> Mbox ByteString +parseMbox = either error id . safeParseMbox "" 0 + +splitMboxMessages :: Int64 -> ByteString -> [Int64 :*: ByteString] +splitMboxMessages !offset !input = + case nextFrom input of + Nothing | C.null input -> [] + | otherwise -> [(offset :*: input)] + Just (!offset', !msg, rest) -> (offset :*: msg) : splitMboxMessages (6 + offset + offset') rest + +finishMboxMessageParsing :: FilePath -> Int64 -> ByteString -> MboxMessage ByteString +finishMboxMessageParsing fp !offset !inp = MboxMessage sender time (fromQuoting pred body) fp offset + where ((sender,time),body) = first (breakAt ' ') $ breakAt '\n' inp + breakAt c = second (C.drop 1 {- a safe tail -}) . C.break (==c) + +-- | Turns an mbox into a 'ByteString' +showMbox :: Mbox ByteString -> ByteString +showMbox = C.intercalate (C.singleton '\n') . map showMboxMessage . mboxMessages + +-- | Returns an header line in mbox format given an mbox message. +showMboxFromLine :: MboxMessage ByteString -> ByteString +showMboxFromLine (MboxMessage sender time _ _ _) = + C.append bFrom + . C.append sender + . C.cons ' ' + . C.append time + . C.cons '\n' + $ C.empty + +-- | Returns a 'ByteString' given an mbox message. +showMboxMessage :: MboxMessage ByteString -> ByteString +showMboxMessage msg = showMboxFromLine msg `C.append` fromQuoting (+1) (_mboxMsgBody msg) + +-- lazyness at work! + +-- | Given a file handle and an offset, 'parseOneMboxMessage' returns +-- the message a this offset. +parseOneMboxMessage :: FilePath -> Handle -> Integer -> IO (MboxMessage C.ByteString) +parseOneMboxMessage fp fh offset = do + hSeek fh AbsoluteSeek offset + s <- C.hGetContents fh + a <- either fail return $ safeParseMbox fp (fromInteger offset) s + (maybe (fail "parseOneMboxMessage: end of file") return . listToMaybe . mboxMessages) a + +readRevMboxFile :: FilePath -> IO (Mbox ByteString) +readRevMboxFile fp = readRevMboxHandle fp =<< openFile fp ReadMode + +-- | @readRevMboxHandle fp h@ returns a reversed mbox for a file handle. +-- The file handle is supposed to be in text mode, readable. +readRevMboxHandle :: FilePath -> Handle -> IO (Mbox ByteString) +readRevMboxHandle fp fh = do siz <- hFileSize fh + readRevMbox fp siz <$> readHandleBackward mboxChunkSize siz fh +-- buffering issues? + +readRevMbox :: FilePath -> Integer -> [ByteString] -> Mbox ByteString +readRevMbox fp filesize chunks = Mbox $ go (fromInteger filesize+1) (filter (not . C.null) chunks) + where go _ [] = [] + go !siz (chunk1:cs) = + case nextFrom chunk1 of + Nothing -> kont siz cs chunk1 + Just (!_backoffset, !msg, rest) -> + let siz' = siz - C.length rest - 6 in + (map finishmmp . reverse . map (first' (+siz')) . splitMboxMessages 0 $ rest) + ++ kont siz' cs msg + + kont !_ [] = (:[]) . finishLast + kont !siz (chunk2:cs2) = \k -> go siz (chunk2 `C.append` k : cs2) + + finishLast = + finishMboxMessageParsing fp 0 . either (error . ("readRevMbox: impossible: " ++)) id . skipFirstFrom + + finishmmp = uncurry' $ finishMboxMessageParsing fp + +-- Not exported. +-- +-- | @readHandleBackward maxChunkSize size h@ lazily reads the @h@ file handle +-- from the end. The file contents is returned as a reversed list of chunks. +-- The result is such that if one apply @C.concat . reverse@ one get +-- the in-order contents. +{- +propIO_read_anydir (Positive maxChunkSize) fh = + do xs <- hGetContent fh + siz <- hFileSize fh + ys <- readHandleBackward maxChunkSize siz fh + xs == C.concat (reverse ys) +-} +readHandleBackward :: Integer -> Integer -> Handle -> IO [ByteString] +readHandleBackward maxChunkSize siz0 fh = go siz0 + where go 0 = return [] + go siz = unsafeInterleaveIO $ + do let delta = min maxChunkSize siz + siz' = siz - delta + hSeek fh AbsoluteSeek siz' + s <- C.hGet fh $ fromInteger delta + (s :) <$> go siz' + +data Direction = Backward | Forward + +opposite :: Direction -> Direction +opposite Forward = Backward +opposite Backward = Forward + +-- | Returns a mbox given a direction (forward/backward) and a file path. +parseMboxFile :: Direction -> FilePath -> IO (Mbox ByteString) +parseMboxFile Forward fp = (either fail return =<<) . (safeParseMbox fp 0 <$>) . C.readFile $ fp +parseMboxFile Backward fp = readRevMboxFile fp + +-- | Returns a mbox list given a direction (forward/backward) and a list of file path. +-- Note that files are opened lazily. +parseMboxFiles :: Direction -> [FilePath] -> IO [Mbox ByteString] +parseMboxFiles Forward [] = (:[]) . parseMbox <$> C.getContents +parseMboxFiles Backward [] = fail "reading backward on standard input does not make sense" +parseMboxFiles dir xs = mapM (unsafeInterleaveIO . parseMboxFile dir) xs + +mboxChunkSize :: Integer +mboxChunkSize = 10*oneMegabyte + +-- one megabyte in bytes +oneMegabyte :: Integer +oneMegabyte = 2 ^ (20 :: Int) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2009, Nicolas Pouillard +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holders nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/codec-mbox.cabal b/codec-mbox.cabal new file mode 100644 --- /dev/null +++ b/codec-mbox.cabal @@ -0,0 +1,22 @@ +name: codec-mbox +cabal-Version: >=1.8 +version: 0.1.0.0 +license: BSD3 +license-File: LICENSE +copyright: (c) Nicolas Pouillard +author: Nicolas Pouillard +maintainer: Nicolas Pouillard +category: Codec +synopsis: A library to read and write mailboxes in mbox format +description: The library provides functions to read, write, and + manipulate mbox's. This library focuses on three points: + robustness, efficency, and scalability. It's using lazy + bytestrings and can handle very big mailboxes. +stability: Provisional +build-type: Simple + +library + build-depends: base (==3.* || ==4.*), bytestring>=0.9, fclabels>=1.0 + exposed-modules: Codec.Mbox + ghc-options: -Wall + extensions: BangPatterns, TypeOperators