diff options
| -rw-r--r-- | MBox.hs | 154 | ||||
| -rw-r--r-- | test10.hs | 151 |
2 files changed, 161 insertions, 144 deletions
@@ -0,0 +1,154 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module MBox + ( + -- TODO don't re-export MBox but use our own Message type + module Export + , getMessageId + , toForest + ) where + +import qualified Data.MBox as Export + +import Control.Applicative +import qualified Data.CaseInsensitive as CI +import qualified Data.List as List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.MBox +import Data.Ord +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text.Lazy (Text) +import Data.Time +import Data.Tree (Tree, Forest) +import qualified Data.Tree as Tree +import qualified MappedSets +import qualified Data.Text.Lazy as Text +import Safe +import System.Locale +import qualified Text.ParserCombinators.Parsec.Rfc2822 as P +import qualified Text.ParserCombinators.Parsec as P + + +type Ident = Text + + +data IdentFields = IdentFields + { messageId :: Ident + , inReplyTo :: [Ident] + , references :: [Ident] + } + deriving Show + + +toForest :: MBox -> Forest Message +toForest mbox = + map (sortTree . fmap (\i -> fromMaybe (error "meh") $ Map.lookup i msgs)) $ + concatMap (Tree.subForest . mkSubTree) (Set.toList $ roots refs) + where + + mkSubTree rootLabel = + Tree.Node rootLabel $ + map mkSubTree (maybe [] Set.toList $ Map.lookup rootLabel backRefs) + + refs = mboxRefs mbox + backRefs = MappedSets.invert refs + msgs = unpackMBox mbox + + +roots :: Ord a => Map a (Set a) -> Set a +roots refs = + Set.unions $ Map.elems $ Map.filter p refs + where + messageIDs = Set.fromList $ Map.keys refs + p = Set.null . Set.intersection messageIDs + + +sortTree :: Tree Message -> Tree Message +sortTree t = + Tree.Node (Tree.rootLabel t) $ + map sortTree $ + List.sortBy (comparing $ getMessageDate . Tree.rootLabel) $ + Tree.subForest t + + +getMessageDate :: Message -> Maybe UTCTime +getMessageDate msg = + parseTime defaultTimeLocale rfc822DateFormat =<< + Text.unpack . snd <$> + (lastMay $ + filter ((==CI.mk "Date") . CI.mk . Text.unpack . fst) $ + headers msg) + + +unpackMBox :: MBox -> Map Ident Message +unpackMBox = + Map.fromList . + map (\msg -> (getMessageId $ headers msg, msg)) + + +getIdentFields :: Message -> IdentFields +getIdentFields m = + IdentFields + { messageId = getMessageId hdrs + , inReplyTo = getInReplyTo hdrs + , references = getReferences hdrs + } + where + hdrs = headers m + + +-- TODO generate default Message-ID if not present +getMessageId :: [Header] -> Ident +getMessageId = + head . + headerMessageIds "Message-ID" + + +getInReplyTo :: [Header] -> [Ident] +getInReplyTo = + headerMessageIds "In-Reply-To" + + +getReferences :: [Header] -> [Ident] +getReferences = + headerMessageIds "References" + + +headerMessageIds :: P.SourceName -> [Header] -> [Ident] +headerMessageIds headerName = + concatMap ( + either ((:[]) . Text.pack . show) id . + parseMsgIds headerName . + snd + ) . + filter ((==CI.mk headerName) . CI.mk . Text.unpack . fst) + + +parseMsgIds :: P.SourceName -> Text -> Either P.ParseError [Ident] +parseMsgIds srcName = + either Left (Right . map (Text.init . Text.tail . Text.pack)) . + P.parse obs_in_reply_to_parser srcName . + Text.unpack + where + --obs_in_reply_to_parser :: CharParser a [String] + obs_in_reply_to_parser = + --filter (not . null) <$> P.many (P.phrase >> return [] <|> P.msg_id) + P.many1 P.msg_id + + +messageRefs :: IdentFields -> [Ident] +messageRefs IdentFields{..} = + if null inReplyTo + then maybe [""] (:[]) (lastMay references) + else inReplyTo + + +mboxRefs :: MBox -> Map Ident (Set Ident) +mboxRefs = + MappedSets.mk . + map (\m -> + let x = getIdentFields m + in (messageId x, messageRefs x)) @@ -5,42 +5,17 @@ --module Main (main) where import Control.Applicative ---import qualified Data.Attoparsec.ByteString.Char8 as A8 -import qualified Data.CaseInsensitive as CI -import qualified Data.List as List -import Data.Maybe -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.MBox -import Data.Ord -import Data.Set (Set) -import qualified Data.Set as Set import qualified Data.Text.Lazy as LT -import Data.Time -import Data.Tree (Tree, Forest) import qualified Data.Tree as Tree -import qualified MappedSets -import Safe +import MBox (MBox) +import qualified MBox import System.Environment -import System.Locale import System.Process -import qualified Text.ParserCombinators.Parsec.Rfc2822 as P -import qualified Text.ParserCombinators.Parsec as P - - -type Ident = LT.Text - -data IdentFields = IdentFields - { messageId :: Ident - , inReplyTo :: [Ident] - , references :: [Ident] - } - deriving Show notmuchShowMBox :: String -> IO MBox notmuchShowMBox searchTerm = - parseMBox . LT.pack <$> readProcess + MBox.parseMBox . LT.pack <$> readProcess "notmuch" [ "show" , "--format=mbox" @@ -50,123 +25,11 @@ notmuchShowMBox searchTerm = "" -getMessageDate :: Message -> Maybe UTCTime -getMessageDate msg = - parseTime defaultTimeLocale rfc822DateFormat =<< - LT.unpack . snd <$> - (lastMay $ - filter ((==CI.mk "Date") . CI.mk . LT.unpack . fst) $ - headers msg) - - -getIdentFields :: Message -> IdentFields -getIdentFields m = - IdentFields - { messageId = getMessageId hdrs - , inReplyTo = getInReplyTo hdrs - , references = getReferences hdrs - } - where - hdrs = headers m - - --- TODO generate default Message-ID if not present -getMessageId :: [Header] -> Ident -getMessageId = - head . - headerMessageIds "Message-ID" - - -getInReplyTo :: [Header] -> [Ident] -getInReplyTo = - headerMessageIds "In-Reply-To" - - -getReferences :: [Header] -> [Ident] -getReferences = - headerMessageIds "References" - - -headerMessageIds :: P.SourceName -> [Header] -> [Ident] -headerMessageIds headerName = - concatMap ( - either ((:[]) . LT.pack . show) id . - parseMsgIds headerName . - snd - ) . - filter ((==CI.mk headerName) . CI.mk . LT.unpack . fst) - - -parseMsgIds :: P.SourceName -> LT.Text -> Either P.ParseError [LT.Text] -parseMsgIds srcName = - either Left (Right . map (LT.init . LT.tail . LT.pack)) . - P.parse obs_in_reply_to_parser srcName . - LT.unpack - where - --obs_in_reply_to_parser :: CharParser a [String] - obs_in_reply_to_parser = - --filter (not . null) <$> P.many (P.phrase >> return [] <|> P.msg_id) - P.many1 P.msg_id - - -messageRefs :: IdentFields -> [Ident] -messageRefs IdentFields{..} = - if null inReplyTo - then maybe [""] (:[]) (lastMay references) - else inReplyTo - - -mboxRefs :: MBox -> Map Ident (Set Ident) -mboxRefs = - MappedSets.mk . - map (\m -> - let x = getIdentFields m - in (messageId x, messageRefs x)) - - -roots :: Ord a => Map a (Set a) -> Set a -roots refs = - Set.unions $ Map.elems $ Map.filter p refs - where - messageIDs = Set.fromList $ Map.keys refs - p = Set.null . Set.intersection messageIDs - - -sortTree :: Tree Message -> Tree Message -sortTree t = - Tree.Node (Tree.rootLabel t) $ - map sortTree $ - List.sortBy (comparing $ getMessageDate . Tree.rootLabel) $ - Tree.subForest t - - -toForest :: MBox -> Forest Message -toForest mbox = - map (sortTree . fmap (\i -> fromMaybe (error "meh") $ Map.lookup i msgs)) $ - concatMap (Tree.subForest . mkSubTree) (Set.toList $ roots refs) - where - - mkSubTree rootLabel = - Tree.Node rootLabel $ - map mkSubTree (maybe [] Set.toList $ Map.lookup rootLabel backRefs) - - refs = mboxRefs mbox - backRefs = MappedSets.invert refs - msgs = unpackMBox mbox - - - -unpackMBox :: MBox -> Map Ident Message -unpackMBox = - Map.fromList . - map (\msg -> (getMessageId $ headers msg, msg)) - - -renderMessage :: Message -> String +renderMessage :: MBox.Message -> String renderMessage msg = - LT.unpack (getMessageId $ headers msg) + LT.unpack (MBox.getMessageId $ MBox.headers msg) ++ " " - ++ drop (length ("From " :: String)) (LT.unpack $ fromLine msg) + ++ drop (length ("From " :: String)) (LT.unpack $ MBox.fromLine msg) main :: IO () @@ -178,4 +41,4 @@ main = do putStrLn . Tree.drawTree . Tree.Node "subject:tree-test" . map (fmap renderMessage) . - toForest + MBox.toForest |