{-# 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, ViewR(..), empty)
import Network.DomainAuth.Mail.Types
import qualified Network.DomainAuth.Utils as B (empty)
import Network.DomainAuth.Utils hiding (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 = 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 = 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 = forall {a}. [a] -> [a]
safeTail forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Header -> Header
fieldsFrom ByteString
key
  where
    safeTail :: [a] -> [a]
safeTail [] = []
    safeTail [a]
xs = forall {a}. [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 = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> (a -> b -> Bool) -> [Maybe b]
enm [ByteString]
kx Header
hx (\ByteString
k Field
h -> ByteString
k 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,2,3] [1,1,2,2,2,3,4,5] (==)
-- [Just 1,Just 2,Just 3]
-- >>> enm [1,1,2,3] [1,1,2,2,2,3,4,5] (==)
-- [Just 1,Just 1,Just 2,Just 3]
-- >>> enm [1,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 forall a. (a -> Bool) -> [a] -> Maybe (a, [a])
fnd (a -> b -> Bool
eq a
k) [b]
hs0 of
  Maybe (b, [b])
Nothing -> forall a. Maybe a
Nothing forall a. a -> [a] -> [a]
: forall a b. [a] -> [b] -> (a -> b -> Bool) -> [Maybe b]
enm [a]
kx [b]
hs0 a -> b -> Bool
eq
  Just (b
x,[b]
hs) -> forall a. a -> Maybe a
Just b
x forall a. a -> [a] -> [a]
: 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
_ [] = forall a. Maybe a
Nothing
fnd a -> Bool
p (a
x:[a]
xs)
  | a -> Bool
p a
x = forall a. a -> Maybe a
Just (a
x, [a]
xs)
  | Bool
otherwise = case forall a. (a -> Bool) -> [a] -> Maybe (a, [a])
fnd a -> Bool
p [a]
xs of
      Maybe (a, [a])
Nothing -> forall a. Maybe a
Nothing
      Just (a
y,[a]
ys) -> forall a. a -> Maybe a
Just (a
y, a
xforall a. a -> [a] -> [a]
:[a]
ys)

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

isKeyOf :: CanonFieldKey -> Field -> Bool
isKeyOf :: ByteString -> Field -> Bool
isKeyOf ByteString
key Field
fld = Field -> ByteString
fieldSearchKey Field
fld 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 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> Builder
concatCRLF 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 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 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr (forall a. (a -> ByteString) -> a -> Builder -> Builder
appendCRLFWith ByteString -> ByteString
modify) forall a. Monoid a => a
B.empty

-- | Removing trailing empty lines.
removeTrailingEmptyLine :: Body -> Body
removeTrailingEmptyLine :: Body -> Body
removeTrailingEmptyLine = forall a. (a -> Bool) -> Seq a -> Seq a
dropWhileR (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 forall a. Seq a -> ViewR a
viewr Seq a
xs of
    ViewR a
EmptyR        -> forall a. Seq a
empty
    Seq a
xs' :> a
x
      | a -> Bool
p a
x       -> forall a. (a -> Bool) -> Seq a -> Seq a
dropWhileR a -> Bool
p Seq a
xs'
      | Bool
otherwise -> Seq a
xs