-- This file is part of purebred-email
-- Copyright (C) 2019  Fraser Tweedale
--
-- purebred-email 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 <http://www.gnu.org/licenses/>.

{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}

{- |

Generators and properties for messages and parts thereof.

-}
module Message where

import Data.Char (isPrint)
import Data.Foldable (fold)
import Data.List.NonEmpty (NonEmpty(..), intersperse)

import Control.Lens (set, view)
import qualified Data.ByteString as B
import Data.CaseInsensitive
import qualified Data.Text as T
import System.Random (uniform)

import Test.Tasty
import Test.Tasty.Hedgehog
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Internal.Gen as Gen
import qualified Hedgehog.Range as Range

import Data.MIME
import Data.IMF.Syntax (isAtext)

tests :: TestTree
tests = testGroup "message tests"
  [ testProperty "message round trip" prop_messageRoundTrip
  , localOption (HedgehogTestLimit (Just 10000)) $
      testProperty "message round trip with From header" prop_messageFromRoundTrip
  , testProperty "mailbox with consecutive spaces" $
      -- https://github.com/purebred-mua/purebred-email/issues/56
      let m = Mailbox (Just "  ") (AddrSpec "!" (DomainDotAtom ("!" :| [])))
      in withTests 1 . property . assert $ renderMailbox m == "\"\\ \\ \" <!@!>"
  ]

printableAsciiChar, printableUnicodeChar, unicodeCharAsciiBias :: Gen Char
printableAsciiChar = Gen.filter isPrint Gen.ascii
printableUnicodeChar = Gen.filter isPrint Gen.unicode

-- | We need a generator that has ascii bias to make sequences
-- like "\r\n" more likely.
unicodeCharAsciiBias = Gen.frequency [(3, Gen.ascii), (1, Gen.unicode)]

asciiText1, unicodeText1 :: Gen T.Text
asciiText1 = Gen.text (Range.linear 1 100) printableAsciiChar
unicodeText1 = Gen.text (Range.linear 1 100) printableUnicodeChar

genTextPlain, genMultipart, genMessage :: Gen MIMEMessage
genTextPlain = createTextPlainMessage <$> Gen.choice [asciiText1, unicodeText1]
genMultipart = depths >>= go
  where
  -- Generate a 50 character multipart boundary.  These MUST be unique
  -- for all (nested) multipart messages.  Assume negligible probability
  -- of collision.
  genBoundary = Gen.generate (\_size seed -> fst (uniform seed))

  go 0 = genTextPlain
  go n = createMultipartMixedMessage
      <$> genBoundary
      <*> ( Gen.nonEmpty (Range.linear 1 10) $
            -- 75% plain, 25% nested multipart
            maybeAp encapsulate 5 $ Gen.frequency [(3, genTextPlain), (1, go (n - 1))]
          )

  -- max depth of 4
  depths :: Gen Int
  depths = Gen.frequency
    [ (1, pure 1)
    , (5, pure 2)
    , (3, pure 3)
    , (1, pure 4)
    ]

  -- Apply the function to the generated value with probability 1-in-/n/.
  maybeAp f n g = Gen.frequency [(n - 1, g), (1, f <$> g)]

genMessage = Gen.choice [ genTextPlain, genMultipart, encapsulate <$> genMessage ]

prop_messageRoundTrip :: Property
prop_messageRoundTrip = property $ do
  msg <- forAll genMessage
  parse (message mime) (renderMessage msg) === Right msg

prop_messageFromRoundTrip :: Property
prop_messageFromRoundTrip = property $ do
  from <- Single <$> forAll genMailbox
  let
    l = headerFrom defaultCharsets
    msg = set l [from] (createTextPlainMessage "Hello")
  (view l <$> parse (message mime) (renderMessage msg)) === Right [from]

genDomain :: Gen Domain
genDomain = DomainDotAtom . fmap mk <$> genDotAtom -- TODO domain literal

genDotAtom :: Gen (NonEmpty B.ByteString)
genDotAtom = Gen.nonEmpty (Range.linear 1 5) (Gen.utf8 (Range.linear 1 20) (Gen.filter isAtext Gen.ascii))

genLocalPart :: Gen B.ByteString
genLocalPart = fold . intersperse "." <$> genDotAtom

genAddrSpec :: Gen AddrSpec
genAddrSpec = AddrSpec <$> genLocalPart <*> genDomain

genMailbox :: Gen Mailbox
genMailbox =
  Mailbox
  <$> Gen.maybe (Gen.text (Range.linear 0 100) unicodeCharAsciiBias)
  <*> genAddrSpec