-- This file is part of purebred-email
-- Copyright (C) 2018 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 #-}
module MIME where
import Control.Monad ((<=<), void)
import Data.Char (toUpper)
import Control.Lens
import qualified Data.ByteString as B
import qualified Data.Text as T
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit ((@?=), Assertion, assertFailure, testCase)
import Test.Tasty.QuickCheck
import Test.QuickCheck.Instances ()
import Data.MIME
unittests :: TestTree
unittests = testGroup "MIME tests"
[ testContentDisposition
, testParse
]
testContentDisposition :: TestTree
testContentDisposition =
testGroup "content disposition"
[ testCase "read empty (plain; should fail)" $
preview lFilename
(Message (Headers [("Content-Disposition", "attachment; filename=")]) (Part ""))
@?= Nothing
, testCase "read empty (quoted)" $
preview lFilename
(Message (Headers [("Content-Disposition", "attachment; filename=\"\"")]) (Part ""))
@?= Just ""
, testCase "read empty (extended)" $
preview lFilename
(Message (Headers [("Content-Disposition", "attachment; filename*=''")]) (Part ""))
@?= Just ""
, testCase "read plain" $
preview lFilename
(Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part ""))
@?= Just "foo.pdf"
, testCase "read quoted" $
preview lFilename
(Message (Headers [("Content-Disposition", "attachment; filename=\"/tmp/foo.pdf\"")]) (Part ""))
@?= Just "/tmp/foo.pdf"
, testCase "set quoted (empty string)" $
(view headers . set lFilename "")
(Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part ""))
@?= Headers [("Content-Disposition", "attachment; filename=\"\"")]
, testCase "set quoted (space char)" $
(view headers . set lFilename "hello world.txt")
(Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part ""))
@?= Headers [("Content-Disposition", "attachment; filename=\"hello\\ world.txt\"")]
, testCase "set quoted (backslash char)" $
(view headers . set lFilename "hello\\world.txt")
(Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part ""))
@?= Headers [("Content-Disposition", "attachment; filename=\"hello\\\\world.txt\"")]
, testCase "set quoted (=)" $
(view headers . set lFilename "hello=world.txt")
(Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part ""))
@?= Headers [("Content-Disposition", "attachment; filename=\"hello=world.txt\"")]
, testCase "set quoted (\")" $
(view headers . set lFilename "hello\"world\".txt")
(Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part ""))
@?= Headers [("Content-Disposition", "attachment; filename=\"hello\\\"world\\\".txt\"")]
, testCase "modify plain -> plain" $
(preview lFilename . over lFilename (T.drop 1))
(Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part ""))
@?= Just "oo.pdf"
, testCase "modify plain -> quoted" $
(preview lFilename . over lFilename (T.map (\c -> if c == '.' then '\\' else c)))
(Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part ""))
@?= Just "foo\\pdf"
, testCase "modify quoted -> plain" $
(preview lFilename . over lFilename stripPath)
(Message (Headers [("Content-Disposition", "attachment; filename=\"/tmp/foo.pdf\"")]) (Part ""))
@?= Just "foo.pdf"
, testCase "modify quoted -> quoted" $
(preview lFilename . over lFilename (T.map toUpper))
(Message (Headers [("Content-Disposition", "attachment; filename=\"/tmp/foo.pdf\"")]) (Part ""))
@?= Just "/TMP/FOO.PDF"
, testCase "set extended (utf-8; raw)" $
(view headers . set lFilename "hello世界.txt")
(Message (Headers [("Content-Disposition", "attachment; filename=\"/tmp/foo.pdf\"")]) (Part ""))
@?= Headers [("Content-Disposition", "attachment; filename*=utf-8''hello%E4%B8%96%E7%95%8C.txt")]
, testCase "set extended (utf-8; readback)" $
(preview lFilename . set lFilename "hello世界.txt")
(Message (Headers [("Content-Disposition", "attachment; filename=\"/tmp/foo.pdf\"")]) (Part ""))
@?= Just "hello世界.txt"
, testCase "set extended (us-ascii; charset omitted; raw)" $
-- control characters will force it to use percent-encoded extended param,
-- but all chars are in us-ascii so charset should be omitted
(view headers . set lFilename "new\nline")
(Message (Headers [("Content-Disposition", "attachment; filename=\"/tmp/foo.pdf\"")]) (Part ""))
@?= Headers [("Content-Disposition", "attachment; filename*=''new%0Aline")]
, testCase "set extended (us-ascii; charset omitted; readback)" $
-- control characters will force it to use percent-encoded extended param,
-- but all chars are in us-ascii so charset should be omitted
(preview lFilename . set lFilename "new\nline")
(Message (Headers [("Content-Disposition", "attachment; filename=\"/tmp/foo.pdf\"")]) (Part ""))
@?= Just "new\nline"
, testProperty "filename round-trip" $ \s ->
(preview lFilename . set lFilename s)
(Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part ""))
== Just s
, testCase "unset multiple filenames" $
set (attachments . headers . contentDisposition . filenameParameter) Nothing
(Message (Headers []) (Multipart
[ Message (Headers [("Content-Disposition", "inline; filename=msg.txt")]) (Part "")
, Message (Headers [("Content-Disposition", "attachment; filename=foo.pdf")]) (Part "")
, Message (Headers [("Content-Disposition", "attachment; filename=bar.pdf")]) (Part "")
]
))
@?=
Message (Headers []) (Multipart
[ Message (Headers [("Content-Disposition", "inline; filename=msg.txt")]) (Part "")
, Message (Headers [("Content-Disposition", "attachment")]) (Part "")
, Message (Headers [("Content-Disposition", "attachment")]) (Part "")
]
)
]
where
lFilename = headers . contentDisposition . filename defaultCharsets
stripPath = snd . T.breakOnEnd "/"
testParse :: TestTree
testParse = testGroup "parsing tests"
[ testCase "nested multipart" $
testParseFile "test-vectors/nested-multipart.eml"
]
testParseFile :: FilePath -> Assertion
testParseFile =
either assertFailure (void . pure) . parse (message mime) <=< B.readFile