-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2025 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Data.Mailbox where

import Control.Applicative (optional)
import Data.Aeson
import Data.Attoparsec.ByteString (Parser)
import Data.Attoparsec.ByteString qualified as BSParser
import Data.Attoparsec.ByteString.Char8 qualified as Char8Parser
import Data.Char qualified as Char
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Imports
import Text.Email.Parser

-- | Mailbox address according to
-- https://www.rfc-editor.org/rfc/rfc5322#section-3.4
data Mailbox = Mailbox
  { name :: Maybe [Text],
    address :: EmailAddress
  }
  deriving (Show, Eq)

parseMailbox :: ByteString -> Either String Mailbox
parseMailbox = BSParser.parseOnly (mailboxParser <* BSParser.endOfInput)

instance FromJSON Mailbox where
  parseJSON =
    withText "Mailbox" $
      either fail pure . parseMailbox . Text.encodeUtf8

-- * Internal

newtype Comment = Comment [CommentContent]

data CommentContent = CommentChar Char | SubComment Comment

atextParser :: Parser Char
atextParser =
  alpha
    <|> num
    <|> allowedSpecials
  where
    alpha = Char8Parser.satisfy (\c -> Char.isAlpha c && Char.isAscii c)
    num = Char8Parser.satisfy Char.isNumber
    allowedSpecials =
      Char8Parser.satisfy $
        -- Make sure the - is the first or the last symbol, otherwise inClass
        -- treats it as a signifier of range
        Char8Parser.inClass "-!#$%&'*+/=?^_`{|}~"

wspParser :: Parser Char
wspParser = Char8Parser.satisfy (\c -> c == ' ' || c == '\t')

crlfParser :: Parser String
crlfParser = do
  void $ Char8Parser.string "\r\n"
  pure "\r\n"

fwsParser :: Parser String
fwsParser =
  let wspsAndCrlf = do
        wsps <- Char8Parser.many' wspParser
        crlf <- crlfParser
        pure $ wsps <> crlf
      notObs = do
        mWspsAndCrlf <- optional wspsAndCrlf
        wsps <- Char8Parser.many1' wspParser
        pure $ fromMaybe "" mWspsAndCrlf <> wsps
   in notObs <|> obsFwsParser

obsFwsParser :: Parser String
obsFwsParser = do
  wsps <- Char8Parser.many1' wspParser
  crlfWsps <- Char8Parser.many' $ do
    crlf <- crlfParser
    wspsAfterCrlf <- Char8Parser.many1' wspParser
    pure $ crlf <> wspsAfterCrlf
  pure $ concat $ wsps : crlfWsps

ctextParser :: Parser Char
ctextParser = do
  let isAllowedChar w =
        (w >= 33 && w <= 39)
          || (w >= 42 && w <= 91)
          || (w >= 93 && w <= 126)
  Char8Parser.satisfy (isAllowedChar . Char.ord) <|> obsNoWsCtl

-- | US-ASCII control characters that do not include the carriage return, line
-- feed, and white space characters
obsNoWsCtl :: Parser Char
obsNoWsCtl = do
  Char8Parser.satisfy
    ( \(ord -> c) ->
        (c >= 1 && c <= 8)
          || c == 11
          || c == 12
          || (c >= 14 && c <= 31)
          || (c == 127)
    )

obsQtextParser :: Parser Char
obsQtextParser = obsNoWsCtl

quotedPairParser :: Parser Char
quotedPairParser = do
  void $ Char8Parser.char '\\'
  vCharParser <|> wspParser

vCharParser :: Parser Char
vCharParser =
  Char8Parser.satisfy (\c -> ord c >= 0x21 && ord c <= 0x7E)

ccontentParser :: Parser CommentContent
ccontentParser =
  fmap CommentChar ctextParser
    <|> fmap CommentChar quotedPairParser
    <|> fmap SubComment commentParser

commentParser :: Parser Comment
commentParser = do
  _ <- Char8Parser.char '('
  comment <- Char8Parser.many' $ do
    _ <- optional fwsParser
    ccontentParser
  _ <- Char8Parser.char ')'
  pure $ Comment comment

cfwsParser :: Parser [Comment]
cfwsParser = do
  let commentWithFws = do
        comment <- Char8Parser.many1' $ do
          _ <- optional fwsParser
          commentParser
        _ <- optional fwsParser
        pure comment
  commentWithFws <|> fmap (const []) fwsParser

atomParser :: Parser String
atomParser = do
  _ <- optional cfwsParser
  atom <- Char8Parser.many1' atextParser
  _ <- optional cfwsParser
  pure atom

qtextParser :: Parser Char
qtextParser =
  let newParser = Char8Parser.satisfy $ \(ord -> c) ->
        c == 33 || (c >= 35 && c <= 91) || (c >= 93 && c <= 126)
   in newParser <|> obsQtextParser

qcontentParser :: Parser Char
qcontentParser = qtextParser <|> quotedPairParser

quotedStringParser :: Parser String
quotedStringParser = do
  _ <- optional cfwsParser
  _ <- Char8Parser.char '"'
  str <- fmap concat . Char8Parser.many' $ do
    mLeadingSpace <- optional fwsParser
    c <- qcontentParser
    pure $ fromMaybe "" mLeadingSpace <> [c]
  mTrailingSpace <- optional fwsParser
  _ <- Char8Parser.char '"'
  pure $ str <> fromMaybe "" mTrailingSpace

wordParser :: Parser String
wordParser = atomParser <|> quotedStringParser

-- | The spec says
--
-- @
-- phrase = 1*word / obs-phrase
-- @
--
-- Here if we tried to write it using '<|>', parising "John Q. Doe" would
-- succeed with a 'many1 wordParser' while having parsed up to "John Q" and the
-- rest of the string will be left for next parsers, which would likely fail. To
-- avoid all that we can use just the obsPhraseParser, which forces the first
-- thing to be a word and then allows for dots and CFWS.
phraseParser :: Parser [String]
phraseParser = obsPhraseParser

-- | Ignores comments
obsPhraseParser :: Parser [String]
obsPhraseParser = do
  w1 <- wordParser
  ws <- fmap catMaybes . Char8Parser.many' $ do
    fmap Just wordParser
      <|> fmap (Just . (: [])) (Char8Parser.char '.')
      <|> fmap (const Nothing) cfwsParser
  pure $ w1 : ws

nameParser :: Parser [Text]
nameParser = map Text.pack <$> phraseParser

-- | Does not implement parsing for obs-angle-addr
angleAddrParser :: Parser EmailAddress
angleAddrParser = do
  _ <- optional cfwsParser
  _ <- Char8Parser.char '<'
  addr <- addrSpec
  _ <- Char8Parser.char '>'
  _ <- optional cfwsParser
  pure addr

nameAddrParser :: Parser Mailbox
nameAddrParser =
  Mailbox
    <$> optional nameParser
    <*> angleAddrParser

mailboxParser :: Parser Mailbox
mailboxParser =
  nameAddrParser <|> fmap (Mailbox Nothing) addrSpec
