{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Much.MBox
    (
      -- TODO don't re-export MBox but use our own Message type
      module Export
    , getMessageId
    , toForest
    ) where

import Control.Applicative
import Data.CaseInsensitive qualified as CI
import Data.List qualified as List
import Data.MBox
import Data.MBox qualified as Export
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe
import Data.Ord
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text.Lazy (Text)
import Data.Text.Lazy qualified as Text
import Data.Time
import Data.Tree (Tree, Forest)
import Data.Tree qualified as Tree
import MappedSets qualified
import Safe
import System.Locale
import Text.ParserCombinators.Parsec qualified as P
import Text.ParserCombinators.Parsec.Rfc2822 qualified 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


-- TODO finde a new home for roots
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


-- TODO finde a new home for sortTree
sortTree :: Tree Message -> Tree Message
sortTree t =
    Tree.Node (Tree.rootLabel t) $
        map sortTree $
        List.sortOn (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 =
    fmap (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))