{-# LANGUAGE OverloadedStrings #-}

-- | Purported Responsible Domain, RFC 4407.
module Network.DomainAuth.PRD.PRD (
    PRD,
    initialPRD,
    pushPRD,
    decidePRD,
    decideFrom,
) where

import Control.Monad
import qualified Data.ByteString.Char8 as BS
import Data.Char
import Data.List (foldl')
import Network.DNS (Domain)
import Network.DomainAuth.Mail
import Network.DomainAuth.PRD.Domain

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

type HD = [(CanonFieldKey, RawFieldValue)]

data DST = DST_Zero | DST_Invalid | DST_Valid Domain deriving (DST -> DST -> Bool
(DST -> DST -> Bool) -> (DST -> DST -> Bool) -> Eq DST
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DST -> DST -> Bool
== :: DST -> DST -> Bool
$c/= :: DST -> DST -> Bool
/= :: DST -> DST -> Bool
Eq, Int -> DST -> ShowS
[DST] -> ShowS
DST -> String
(Int -> DST -> ShowS)
-> (DST -> String) -> ([DST] -> ShowS) -> Show DST
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DST -> ShowS
showsPrec :: Int -> DST -> ShowS
$cshow :: DST -> String
show :: DST -> String
$cshowList :: [DST] -> ShowS
showList :: [DST] -> ShowS
Show)

-- | Abstract type for context to decide PRD(purported responsible domain)
--   according to RFC 4407.
data PRD = PRD
    { PRD -> DST
praFrom :: DST
    , PRD -> DST
praSender :: DST
    , PRD -> DST
praResentFrom :: DST
    , PRD -> DST
praResentSender :: DST
    , PRD -> HD
praHeader :: HD
    }
    deriving (Int -> PRD -> ShowS
[PRD] -> ShowS
PRD -> String
(Int -> PRD -> ShowS)
-> (PRD -> String) -> ([PRD] -> ShowS) -> Show PRD
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PRD -> ShowS
showsPrec :: Int -> PRD -> ShowS
$cshow :: PRD -> String
show :: PRD -> String
$cshowList :: [PRD] -> ShowS
showList :: [PRD] -> ShowS
Show)

-- | Initial context of PRD.
initialPRD :: PRD
initialPRD :: PRD
initialPRD =
    PRD
        { praFrom :: DST
praFrom = DST
DST_Zero
        , praSender :: DST
praSender = DST
DST_Zero
        , praResentFrom :: DST
praResentFrom = DST
DST_Zero
        , praResentSender :: DST
praResentSender = DST
DST_Zero
        , praHeader :: HD
praHeader = []
        }

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

-- | Pushing a field key and its value in to the PRD context.
pushPRD :: RawFieldKey -> RawFieldValue -> PRD -> PRD
pushPRD :: ByteString -> ByteString -> PRD -> PRD
pushPRD ByteString
key ByteString
val PRD
ctx = case ByteString
ckey of
    ByteString
"from" -> PRD -> Maybe ByteString -> PRD
pushFrom PRD
ctx' Maybe ByteString
jdom
    ByteString
"sender" -> PRD -> Maybe ByteString -> PRD
pushSender PRD
ctx' Maybe ByteString
jdom
    ByteString
"resent-from" -> PRD -> Maybe ByteString -> PRD
pushResentFrom PRD
ctx' Maybe ByteString
jdom
    ByteString
"resent-sender" -> PRD -> Maybe ByteString -> PRD
pushResentSender PRD
ctx' Maybe ByteString
jdom
    ByteString
_ -> PRD
ctx'
  where
    ckey :: ByteString
ckey = (Char -> Char) -> ByteString -> ByteString
BS.map Char -> Char
toLower ByteString
key
    jdom :: Maybe ByteString
jdom = ByteString -> Maybe ByteString
extractDomain ByteString
val
    ctx' :: PRD
ctx' = PRD
ctx{praHeader = (ckey, val) : praHeader ctx}

-- | Deciding PRD from the RPD context.
--
-- >>> let maddr1 = "alice@alice.example.jp"
-- >>> let maddr2 = "bob@bob.example.jp"
-- >>> let maddr3 = "chris@chris.example.jp"
-- >>> let maddr4 = "dave@dave.example.jp"
-- >>> decidePRD (pushPRD "from" "alice@alice.example.jp" initialPRD)
-- Just "alice.example.jp"
-- >>> :{
-- decidePRD (pushPRD "from" maddr1
--          $ pushPRD "from" maddr1 initialPRD)
-- :}
-- Nothing
--
-- >>> :{
-- decidePRD (pushPRD "sender" maddr2
--          $ pushPRD "from" maddr1
--          $ pushPRD "from" maddr1 initialPRD)
-- :}
-- Just "bob.example.jp"
--
-- >>> :{
-- decidePRD (pushPRD "sender" maddr2
--          $ pushPRD "sender" maddr2
--          $ pushPRD "from" maddr1
--          $ pushPRD "from" maddr1 initialPRD)
-- :}
-- Nothing
--
-- >>> :{
-- decidePRD (pushPRD "resent-from" maddr3
--          $ pushPRD "sender" maddr2
--          $ pushPRD "sender" maddr2
--          $ pushPRD "from" maddr1
--          $ pushPRD "from" maddr1 initialPRD)
-- :}
-- Just "chris.example.jp"
--
-- >>> :{
-- decidePRD (pushPRD "resent-sender" maddr4
--           $ pushPRD "resent-from" maddr3
--           $ pushPRD "sender" maddr2
--           $ pushPRD "sender" maddr2
--           $ pushPRD "from" maddr1
--           $ pushPRD "from" maddr1 initialPRD)
-- :}
-- Just "dave.example.jp"
--
-- >>> :{
-- decidePRD (pushPRD "resent-sender" maddr4
--          $ pushPRD "resent-from" maddr3
--          $ pushPRD "sender" maddr2
--          $ pushPRD "received" "dummy"
--          $ pushPRD "from" maddr1 initialPRD)
-- :}
-- Just "dave.example.jp"
--
-- >>> :{
-- decidePRD (pushPRD "resent-sender" maddr4
--          $ pushPRD "received" "dummy"
--          $ pushPRD "resent-from" maddr3
--          $ pushPRD "sender" maddr2
--          $ pushPRD "from" maddr1 initialPRD)
-- :}
-- Just "chris.example.jp"
--
-- >>> :{
-- decidePRD (pushPRD "received" "dummy"
--           $ pushPRD "resent-sender" maddr4
--           $ pushPRD "resent-from" maddr3
--           $ pushPRD "sender" maddr2
--           $ pushPRD "from" maddr1 initialPRD)
-- :}
-- Just "dave.example.jp"
decidePRD :: PRD -> Maybe Domain
decidePRD :: PRD -> Maybe ByteString
decidePRD PRD
ctx =
    let jds :: [DST]
jds =
            [ PRD -> DST
praResentSender PRD
ctx
            , PRD -> DST
praResentFrom PRD
ctx
            , PRD -> DST
praSender PRD
ctx
            , PRD -> DST
praFrom PRD
ctx
            ]
     in (Maybe ByteString -> Maybe ByteString -> Maybe ByteString)
-> Maybe ByteString -> [Maybe ByteString] -> Maybe ByteString
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Maybe ByteString -> Maybe ByteString -> Maybe ByteString
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus Maybe ByteString
forall a. Maybe a
forall (m :: * -> *) a. MonadPlus m => m a
mzero ([Maybe ByteString] -> Maybe ByteString)
-> [Maybe ByteString] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ (DST -> Maybe ByteString) -> [DST] -> [Maybe ByteString]
forall a b. (a -> b) -> [a] -> [b]
map DST -> Maybe ByteString
toMaybe [DST]
jds

-- | Taking the value of From: from the RPD context.
--
-- >>> decideFrom (pushPRD "from" "alice@alice.example.jp" initialPRD)
-- Just "alice.example.jp"
decideFrom :: PRD -> Maybe Domain
decideFrom :: PRD -> Maybe ByteString
decideFrom = DST -> Maybe ByteString
toMaybe (DST -> Maybe ByteString)
-> (PRD -> DST) -> PRD -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PRD -> DST
praFrom

toMaybe :: DST -> Maybe Domain
toMaybe :: DST -> Maybe ByteString
toMaybe (DST_Valid ByteString
d) = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
d
toMaybe DST
_ = Maybe ByteString
forall a. Maybe a
Nothing

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

pushFrom :: PRD -> Maybe Domain -> PRD
pushFrom :: PRD -> Maybe ByteString -> PRD
pushFrom PRD
ctx Maybe ByteString
Nothing = PRD
ctx{praFrom = DST_Invalid}
pushFrom PRD
ctx (Just ByteString
dom) = PRD
ctx{praFrom = from}
  where
    from :: DST
from = case PRD -> DST
praFrom PRD
ctx of
        DST
DST_Zero -> ByteString -> DST
DST_Valid ByteString
dom
        DST
_ -> DST
DST_Invalid

pushSender :: PRD -> Maybe Domain -> PRD
pushSender :: PRD -> Maybe ByteString -> PRD
pushSender PRD
ctx Maybe ByteString
Nothing = PRD
ctx{praSender = DST_Invalid}
pushSender PRD
ctx (Just ByteString
dom) = PRD
ctx{praSender = sender}
  where
    sender :: DST
sender = case PRD -> DST
praSender PRD
ctx of
        DST
DST_Zero -> ByteString -> DST
DST_Valid ByteString
dom
        DST
_ -> DST
DST_Invalid

pushResentFrom :: PRD -> Maybe Domain -> PRD
pushResentFrom :: PRD -> Maybe ByteString -> PRD
pushResentFrom PRD
ctx Maybe ByteString
Nothing = PRD
ctx{praResentFrom = DST_Invalid}
pushResentFrom PRD
ctx (Just ByteString
dom) = PRD
ctx{praResentFrom = rfrom}
  where
    rfrom :: DST
rfrom = case PRD -> DST
praResentFrom PRD
ctx of
        DST
DST_Zero -> ByteString -> DST
DST_Valid ByteString
dom
        DST_Valid ByteString
d -> ByteString -> DST
DST_Valid ByteString
d
        DST
DST_Invalid -> DST
DST_Invalid

pushResentSender :: PRD -> Maybe Domain -> PRD
pushResentSender :: PRD -> Maybe ByteString -> PRD
pushResentSender PRD
ctx Maybe ByteString
Nothing = PRD
ctx{praResentSender = DST_Invalid}
pushResentSender PRD
ctx (Just ByteString
dom)
    | PRD -> DST
praResentFrom PRD
ctx DST -> DST -> Bool
forall a. Eq a => a -> a -> Bool
== DST
DST_Zero = PRD
ctx{praResentSender = rsender}
    | HD -> Bool
isFirstBlock (PRD -> HD
praHeader PRD
ctx) = PRD
ctx{praResentSender = DST_Valid dom}
    | Bool
otherwise = PRD
ctx{praResentSender = DST_Invalid}
  where
    rsender :: DST
rsender = case PRD -> DST
praResentSender PRD
ctx of
        DST
DST_Zero -> ByteString -> DST
DST_Valid ByteString
dom
        DST_Valid ByteString
d -> ByteString -> DST
DST_Valid ByteString
d
        DST
DST_Invalid -> DST
DST_Invalid

isFirstBlock :: HD -> Bool
isFirstBlock :: HD -> Bool
isFirstBlock HD
hdr = ((ByteString, ByteString) -> Bool) -> HD -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (ByteString, ByteString) -> Bool
forall {b}. (ByteString, b) -> Bool
rr (HD -> Bool) -> (HD -> HD) -> HD -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, ByteString) -> Bool) -> HD -> HD
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (ByteString, ByteString) -> Bool
forall {b}. (ByteString, b) -> Bool
end (HD -> Bool) -> HD -> Bool
forall a b. (a -> b) -> a -> b
$ HD
hdr
  where
    end :: (ByteString, b) -> Bool
end = (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"resent-from") (ByteString -> Bool)
-> ((ByteString, b) -> ByteString) -> (ByteString, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, b) -> ByteString
forall a b. (a, b) -> a
fst
    rr :: (ByteString, b) -> Bool
rr = (ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ByteString
"received", ByteString
"return-path"]) (ByteString -> Bool)
-> ((ByteString, b) -> ByteString) -> (ByteString, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, b) -> ByteString
forall a b. (a, b) -> a
fst