module Mail.Parser (run, Message (..), Part (..)) where

import Common (startsWith, trim)
import Control.Monad.State (State, evalState, get, gets, modify)
import Data.Char (isSpace)
import Data.List (intercalate)
import Intro
import Mail.Header (Header)
import qualified Mail.Header as H

data Message = Message
  { headers :: [Header]
  , body :: [Part]
  }
  deriving (Show)

data Part = Part
  { headers :: [Header]
  , body :: String -- TOOD: Scoped Fields extension
  }
  deriving (Show, Eq)

data ParserState = InHeader (Maybe Header) | InBody deriving (Show, Eq)

data Parser = Parser
  { pHeaders :: [Header]
  , pBody :: [String]
  , pState :: ParserState
  , pErrors :: [String]
  }
  deriving (Show)

type MessageM = State Parser Message

type PartM = State Parser Part

newParser :: Parser
newParser = Parser [] [] (InHeader Nothing) []

run :: [String] -> Message
run xs = evalState (parseMail xs) newParser

parseMail :: [String] -> MessageM
parseMail [] = gets (evalState parseMailBody)
parseMail (x : xs) = do
  s <- get
  case pState s of
    InHeader Nothing
      | trim x == "" -> modify (setState InBody)
      | otherwise -> case kv x of
          Just (k, v) -> modify (setInHeader (k, v))
          Nothing -> modify (setInHeaderStart . pushError x)
    InHeader (Just (k, v))
      | trim x == "" -> modify (setState InBody . pushHeader (k, v))
      | startsWith isSpace x -> modify (setInHeader (k, v ++ x))
      | otherwise -> case kv x of
          Just (k', v') -> modify (setInHeader (k', v') . pushHeader (k, v))
          Nothing -> modify (setInHeaderStart . pushHeader (k, v) . pushError x)
    InBody -> modify (pushBody x)
  parseMail xs

parseMailBody :: MessageM
parseMailBody = do
  s <- get
  pure $ case getBoundary s of
    Just boundary ->
      Message
        { headers = pHeaders s
        , body = getPart <$> bodyParts (reverse $ pBody s) boundary
        }
    Nothing ->
      Message
        { headers = pHeaders s
        , body = [Part{headers = [], body = intercalate "\r\n" . reverse $ pBody s}]
        }
 where
  getBoundary s = H.boundary =<< (H.contentType . pHeaders) s
  getPart part = evalState (parsePart part) newParser

parsePart :: [String] -> PartM
parsePart [] = do
  s <- get
  pure $ Part{headers = pHeaders s, body = intercalate "\r\n" . reverse $ pBody s}
parsePart (x : xs) = do
  s <- get
  case pState s of
    InHeader Nothing
      | trim x == "" -> modify (setState InBody)
      | otherwise -> case kv x of
          Just (k, v) -> modify (setInHeader (k, v))
          Nothing -> modify (setInHeaderStart . pushError x)
    InHeader (Just (k, v))
      | trim x == "" -> modify (setState InBody . pushHeader (k, v))
      | startsWith isSpace x -> modify (setInHeader (k, v ++ x))
      | otherwise -> case kv x of
          Just (k', v') -> modify (setInHeader (k', v') . pushHeader (k, v))
          Nothing -> modify (setInHeaderStart . pushHeader (k, v) . pushError x)
    InBody -> modify (pushBody x)
  parsePart xs

pushHeader :: Header -> Parser -> Parser
pushHeader x p = p{pHeaders = (trim <$> x) : pHeaders p}

pushBody :: String -> Parser -> Parser
pushBody x p = p{pBody = trim x : pBody p}

pushError :: String -> Parser -> Parser
pushError x p = p{pErrors = x : pErrors p}

setState :: ParserState -> Parser -> Parser
setState x p = p{pState = x}

setInHeaderStart :: Parser -> Parser
setInHeaderStart p = p{pState = InHeader Nothing}

setInHeader :: Header -> Parser -> Parser
setInHeader x p = p{pState = InHeader $ Just x}

kv :: String -> Maybe (String, String)
kv x =
  case break (== ':') x of
    (k, _ : v) -> Just (k, v)
    (_, []) -> Nothing

bodyParts :: [String] -> String -> [[String]]
bodyParts lines' boundary = filter (not . isEmptyPart) $ go lines' [] []
 where
  go :: [String] -> [String] -> [[String]] -> [[String]]
  go [] _ parts = parts
  go (x : xs) acc parts
    | trim x == ("--" ++ boundary) = go xs [] (reverse acc : parts)
    | otherwise = go xs (x : acc) parts

isEmptyPart :: [String] -> Bool
isEmptyPart [""] = True
isEmptyPart _ = False