{-# LANGUAGE OverloadedStrings #-}

module Network.DomainAuth.Mail.Mail (
    lookupField,
    fieldsFrom,
    fieldsAfter,
    fieldsWith,
    fieldValueFolded,
    fieldValueUnfolded,
    fromBody,
    fromBodyWith,
    removeTrailingEmptyLine,
) where

import Data.ByteString (ByteString)
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL
import qualified Data.Foldable as F (foldr)
import Data.List
import Data.Maybe (catMaybes)
import Data.Sequence (Seq, ViewR (..), empty, viewr)
import Network.DomainAuth.Mail.Types
import Network.DomainAuth.Utils hiding (empty)
import qualified Network.DomainAuth.Utils as B (empty)

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Data.ByteString.Char8

----------------------------------------------------------------

-- | Looking up 'Field' from 'Header' with 'FieldKey'.
lookupField :: FieldKey -> Header -> Maybe Field
lookupField :: ByteString -> Header -> Maybe Field
lookupField ByteString
key Header
hdr = (Field -> Bool) -> Header -> Maybe Field
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (ByteString
ckey ByteString -> Field -> Bool
`isKeyOf`) Header
hdr
  where
    ckey :: ByteString
ckey = ByteString -> ByteString
canonicalizeKey ByteString
key

-- | Obtaining the 'Field' of 'FieldKey' and all fields under 'FieldKey'.
fieldsFrom :: FieldKey -> Header -> Header
fieldsFrom :: ByteString -> Header -> Header
fieldsFrom ByteString
key = (Field -> Bool) -> Header -> Header
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (ByteString
ckey ByteString -> Field -> Bool
`isNotKeyOf`)
  where
    ckey :: ByteString
ckey = ByteString -> ByteString
canonicalizeKey ByteString
key

-- | Obtaining all fields under 'FieldKey'.
fieldsAfter :: FieldKey -> Header -> Header
fieldsAfter :: ByteString -> Header -> Header
fieldsAfter ByteString
key = Header -> Header
forall {a}. [a] -> [a]
safeTail (Header -> Header) -> (Header -> Header) -> Header -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Header -> Header
fieldsFrom ByteString
key
  where
    safeTail :: [a] -> [a]
safeTail [] = []
    safeTail [a]
xs = [a] -> [a]
forall a. HasCallStack => [a] -> [a]
tail [a]
xs

-- RFC 4871 is ambiguous, so implement only normal case.

-- | Obtaining all fields with DKIM algorithm.
--
-- >>> fieldsWith ["from","to","subject","date","message-id"] [Field "from" "From" ["foo"],Field "to" "To" ["bar"],Field "subject" "Subject" ["baz"],Field "date" "Date" ["qux"],Field "message-id" "Message-Id" ["quux"], Field "received" "Received" ["fiz"], Field "filtered-out" "Filtered-Out" ["buzz"], Field "not-needed" "Not-Needed" ["fizz"]]
-- [Field {fieldSearchKey = "from", fieldKey = "From", fieldValue = ["foo"]},Field {fieldSearchKey = "to", fieldKey = "To", fieldValue = ["bar"]},Field {fieldSearchKey = "subject", fieldKey = "Subject", fieldValue = ["baz"]},Field {fieldSearchKey = "date", fieldKey = "Date", fieldValue = ["qux"]},Field {fieldSearchKey = "message-id", fieldKey = "Message-Id", fieldValue = ["quux"]}]
fieldsWith :: [CanonFieldKey] -> Header -> Header
fieldsWith :: [ByteString] -> Header -> Header
fieldsWith [ByteString]
kx Header
hx = [Maybe Field] -> Header
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Field] -> Header) -> [Maybe Field] -> Header
forall a b. (a -> b) -> a -> b
$ [ByteString]
-> Header -> (ByteString -> Field -> Bool) -> [Maybe Field]
forall a b. [a] -> [b] -> (a -> b -> Bool) -> [Maybe b]
enm [ByteString]
kx Header
hx (\ByteString
k Field
h -> ByteString
k ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Field -> ByteString
fieldSearchKey Field
h)

-- | RFC 6376 says:
--    Signers MAY claim to have signed header fields that do not exist
--    (that is, Signers MAY include the header field name in the "h=" tag
--    even if that header field does not exist in the message).  When
--    computing the signature, the nonexisting header field MUST be treated
--    as the null string (including the header field name, header field
--    value, all punctuation, and the trailing CRLF).
--
--       INFORMATIVE RATIONALE: This allows Signers to explicitly assert
--       the absence of a header field; if that header field is added
--       later, the signature will fail.
--
--      INFORMATIVE NOTE: A header field name need only be listed once
--      more than the actual number of that header field in a message at
--      the time of signing in order to prevent any further additions.
--      For example, if there is a single Comments header field at the
--      time of signing, listing Comments twice in the "h=" tag is
--      sufficient to prevent any number of Comments header fields from
--      being appended; it is not necessary (but is legal) to list
--      Comments three or more times in the "h=" tag.
--
-- 'Notihng' represents the null above.
--
-- >>> enm [1::Int,2,3] [1,1,2,2,2,3,4,5] (==)
-- [Just 1,Just 2,Just 3]
-- >>> enm [1::Int,1,2,3] [1,1,2,2,2,3,4,5] (==)
-- [Just 1,Just 1,Just 2,Just 3]
-- >>> enm [1::Int,1,1,2,3] [1,1,2,2,2,3,4,5] (==)
-- [Just 1,Just 1,Nothing,Just 2,Just 3]
enm :: [a] -> [b] -> (a -> b -> Bool) -> [Maybe b]
enm :: forall a b. [a] -> [b] -> (a -> b -> Bool) -> [Maybe b]
enm [] [b]
_ a -> b -> Bool
_ = []
enm [a]
_ [] a -> b -> Bool
_ = []
enm (a
k : [a]
kx) [b]
hs0 a -> b -> Bool
eq = case (b -> Bool) -> [b] -> Maybe (b, [b])
forall a. (a -> Bool) -> [a] -> Maybe (a, [a])
fnd (a -> b -> Bool
eq a
k) [b]
hs0 of
    Maybe (b, [b])
Nothing -> Maybe b
forall a. Maybe a
Nothing Maybe b -> [Maybe b] -> [Maybe b]
forall a. a -> [a] -> [a]
: [a] -> [b] -> (a -> b -> Bool) -> [Maybe b]
forall a b. [a] -> [b] -> (a -> b -> Bool) -> [Maybe b]
enm [a]
kx [b]
hs0 a -> b -> Bool
eq
    Just (b
x, [b]
hs) -> b -> Maybe b
forall a. a -> Maybe a
Just b
x Maybe b -> [Maybe b] -> [Maybe b]
forall a. a -> [a] -> [a]
: [a] -> [b] -> (a -> b -> Bool) -> [Maybe b]
forall a b. [a] -> [b] -> (a -> b -> Bool) -> [Maybe b]
enm [a]
kx [b]
hs a -> b -> Bool
eq

-- >>> fnd (== 1) [1,2,3]
-- Just (1,[2,3])
-- >>> fnd (== 2) [1,2,3]
-- Just (2,[1,3])
-- >>> fnd (== 3) [1,2,3]
-- Just (3,[1,2])
-- >>> fnd (== 4) [1,2,3]
-- Nothing
fnd :: (a -> Bool) -> [a] -> Maybe (a, [a])
fnd :: forall a. (a -> Bool) -> [a] -> Maybe (a, [a])
fnd a -> Bool
_ [] = Maybe (a, [a])
forall a. Maybe a
Nothing
fnd a -> Bool
p (a
x : [a]
xs)
    | a -> Bool
p a
x = (a, [a]) -> Maybe (a, [a])
forall a. a -> Maybe a
Just (a
x, [a]
xs)
    | Bool
otherwise = case (a -> Bool) -> [a] -> Maybe (a, [a])
forall a. (a -> Bool) -> [a] -> Maybe (a, [a])
fnd a -> Bool
p [a]
xs of
        Maybe (a, [a])
Nothing -> Maybe (a, [a])
forall a. Maybe a
Nothing
        Just (a
y, [a]
ys) -> (a, [a]) -> Maybe (a, [a])
forall a. a -> Maybe a
Just (a
y, a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ys)

----------------------------------------------------------------

isKeyOf :: CanonFieldKey -> Field -> Bool
isKeyOf :: ByteString -> Field -> Bool
isKeyOf ByteString
key Field
fld = Field -> ByteString
fieldSearchKey Field
fld ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
key

isNotKeyOf :: CanonFieldKey -> Field -> Bool
isNotKeyOf :: ByteString -> Field -> Bool
isNotKeyOf ByteString
key Field
fld = Field -> ByteString
fieldSearchKey Field
fld ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
key

----------------------------------------------------------------

-- | Obtaining folded (raw) field value.
fieldValueFolded :: Field -> RawFieldValue
fieldValueFolded :: Field -> ByteString
fieldValueFolded = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (Field -> ByteString) -> Field -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString)
-> (Field -> Builder) -> Field -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> Builder
concatCRLF ([ByteString] -> Builder)
-> (Field -> [ByteString]) -> Field -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> [ByteString]
fieldValue

-- | Obtaining unfolded (removing CRLF) field value.
fieldValueUnfolded :: Field -> RawFieldValue
fieldValueUnfolded :: Field -> ByteString
fieldValueUnfolded = [ByteString] -> ByteString
BS8.concat ([ByteString] -> ByteString)
-> (Field -> [ByteString]) -> Field -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> [ByteString]
fieldValue

----------------------------------------------------------------

-- | Obtaining body.
fromBody :: Body -> Builder
fromBody :: Body -> Builder
fromBody = (ByteString -> ByteString) -> Body -> Builder
fromBodyWith ByteString -> ByteString
forall a. a -> a
id

-- | Obtaining body with a canonicalization function.
fromBodyWith :: (ByteString -> ByteString) -> Body -> Builder
fromBodyWith :: (ByteString -> ByteString) -> Body -> Builder
fromBodyWith ByteString -> ByteString
modify = (ByteString -> Builder -> Builder) -> Builder -> Body -> Builder
forall a b. (a -> b -> b) -> b -> Seq a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr ((ByteString -> ByteString) -> ByteString -> Builder -> Builder
forall a. (a -> ByteString) -> a -> Builder -> Builder
appendCRLFWith ByteString -> ByteString
modify) Builder
forall a. Monoid a => a
B.empty

-- | Removing trailing empty lines.
removeTrailingEmptyLine :: Body -> Body
removeTrailingEmptyLine :: Body -> Body
removeTrailingEmptyLine = (ByteString -> Bool) -> Body -> Body
forall a. (a -> Bool) -> Seq a -> Seq a
dropWhileR (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"")

-- dropWhileR is buggy, sigh.
dropWhileR :: (a -> Bool) -> Seq a -> Seq a
dropWhileR :: forall a. (a -> Bool) -> Seq a -> Seq a
dropWhileR a -> Bool
p Seq a
xs = case Seq a -> ViewR a
forall a. Seq a -> ViewR a
viewr Seq a
xs of
    ViewR a
EmptyR -> Seq a
forall a. Seq a
empty
    Seq a
xs' :> a
x
        | a -> Bool
p a
x -> (a -> Bool) -> Seq a -> Seq a
forall a. (a -> Bool) -> Seq a -> Seq a
dropWhileR a -> Bool
p Seq a
xs'
        | Bool
otherwise -> Seq a
xs