-- -*- Mode: haskell; indent-tabs-mode: nil -*-
module SingleMail
    ( mailToEstDoc
    , addSingleMail
    )
    where

import Text.Estraier.EstDoc as EstDoc
import Text.Estraier.EstDB
import Text.Estraier.Misc

import QDBM.Curia

import Data.Char
import Data.Maybe

import Control.Monad

import ParseMail

maybeM (Just x) m = m x
maybeM Nothing  _ = return ()

mailToEstDoc mail tags =
    do doc <- EstDoc.new
       addAuthor doc
       addTitle doc
       addDate doc
       addTags doc
       EstDoc.addAttr doc "@type" "message/rfc822"
       EstDoc.addAttr doc "@size" (show (length mail))
       EstDoc.addAttr doc "@uri" messageid
       mapM_ (addAttrs doc) headers
       addMimeText doc mailbody
       return doc
    where
      mailbody = parseMail mail
      headers = case mailbody of
                  SinglePart hs _ -> hs
                  MultiPart hs _  -> hs
      addMimeText doc (SinglePart header body) =
          mapM_ (EstDoc.addText doc . dropWhile (flip elem " >|\t")) $
                lines body
      addMimeText doc (MultiPart header body) =
          mapM_ (addMimeText doc) body
      addAuthor doc = maybeM (lookup "from" headers) $ \author ->
                      do EstDoc.addHiddenText doc author
                         EstDoc.addAttr doc "@author" author
      addTitle doc  = maybeM (lookup "subject" headers) $ \title ->
                      do EstDoc.addHiddenText doc title
                         EstDoc.addAttr doc "@title" title
      addDate doc   = maybeM (lookup "date" headers) $ \date ->
                      do EstDoc.addAttr doc "@cdate" date
                         EstDoc.addAttr doc "@mdate" date
      addTags doc   = let brackets = maybe [] parseSubject $
                                     lookup "subject" headers
                          mlname = fromMaybe "" $ lookup "x-ml-name" headers
                          tags = fromMaybe "" (lookup "x-mailtag" headers)
                      in EstDoc.addAttr doc "@mailtag" $
                             unwords (mlname : tags : brackets)
      addAttrs doc (key, val) = EstDoc.addAttr doc ('@':key) val
      messageid = fromMaybe "" $ lookup "message-id" headers

getMessageId mail = getMid mid
    where mid = dropWhile (not . flip startWith "message-id:" . map toLower) $ takeWhile (not.null) $ lines mail
          getMid [] = ""
          getMid (x:xs) = unwords $ map (dropWhile isSpace) $
                          tail (dropWhile (/=':') x)
                                   : (takeWhile (isSpace . head) xs)

addSingleMail mail tags (edb, fdb) =
    do messageid <- return $ getMessageId mail
       alreadyExists <- hasDocURI edb messageid
       unless alreadyExists $
              do doc <- mailToEstDoc mail tags
                 mid' <- EstDoc.attr doc "@uri"
                 unless (maybe False null mid') $
                        do { putDoc edb doc True
                           ; insertLarge fdb messageid mail
                           } 
                 EstDoc.deleteDoc doc