test10: initial commit (MBox -> Tree Message)

3 files changed, 211 insertions, 0 deletions

diff --git a/MappedSets.hs b/MappedSets.hs
new file mode 100644
index 0000000..c3045c6
--- /dev/null
+++ b/MappedSets.hs
@@ -0,0 +1,28 @@
+module MappedSets (invert, mk) where
+
+import           Control.Arrow
+import           Data.Map.Strict   (Map)
+import qualified Data.Map.Strict as Map
+import           Data.Maybe
+import           Data.Set   (Set)
+import qualified Data.Set as Set
+
+
+mk :: (Ord a, Ord b) => [(a, [b])] -> Map a (Set b)
+mk =
+    Map.fromList . map (second Set.fromList)
+
+
+invert :: (Ord a, Ord b) => Map a (Set b) -> Map b (Set a)
+invert =
+    Map.foldrWithKey invert1 Map.empty
+
+
+invert1 :: (Ord a, Ord b) => a -> Set b -> Map b (Set a) -> Map b (Set a)
+invert1 k v a =
+    Set.foldr (upsert k) a v
+
+
+upsert :: (Ord a, Ord b) => a -> b -> Map b (Set a) -> Map b (Set a)
+upsert k =
+    Map.alter (Just . Set.insert k . fromMaybe Set.empty)
diff --git a/env.nix b/env.nix
index 86f17cc..0e94951 100644
--- a/env.nix
+++ b/env.nix
@@ -23,6 +23,8 @@ let
       docopt
       email-header
       friendly-time
+      hsemail
+      mbox
       mime
       mime-mail # because modified showAddress
       process
diff --git a/test10.hs b/test10.hs
new file mode 100644
index 0000000..53ffe52
--- /dev/null
+++ b/test10.hs
@@ -0,0 +1,181 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+--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           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
+        "notmuch"
+        [ "show"
+        , "--format=mbox"
+        , "--entire-thread=true"
+        , 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 msg =
+    LT.unpack (getMessageId $ headers msg)
+    ++ " "
+    ++ drop (length ("From " :: String)) (LT.unpack $ fromLine msg)
+
+
+main :: IO ()
+main = do
+    -- load-env hack
+    maybe (return ()) (setEnv "HOME") =<< lookupEnv "OLDHOME"
+
+    notmuchShowMBox "tree1" >>=
+        putStrLn . Tree.drawTree .
+        Tree.Node "subject:tree-test" .
+        map (fmap renderMessage) .
+        toForest