{-# 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DST -> DST -> Bool
$c/= :: DST -> DST -> Bool
== :: DST -> DST -> Bool
$c== :: DST -> DST -> Bool
Eq, Int -> DST -> ShowS
[DST] -> ShowS
DST -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DST] -> ShowS
$cshowList :: [DST] -> ShowS
show :: DST -> String
$cshow :: DST -> String
showsPrec :: Int -> DST -> ShowS
$cshowsPrec :: Int -> 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PRD] -> ShowS
$cshowList :: [PRD] -> ShowS
show :: PRD -> String
$cshow :: PRD -> String
showsPrec :: Int -> PRD -> ShowS
$cshowsPrec :: Int -> 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 :: HD
praHeader = (ByteString
ckey,ByteString
val) forall a. a -> [a] -> [a]
: PRD -> HD
praHeader PRD
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 forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus forall (m :: * -> *) a. MonadPlus m => m a
mzero forall a b. (a -> b) -> a -> b
$ 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 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) = forall a. a -> Maybe a
Just ByteString
d
toMaybe DST
_             = 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
praFrom = DST
DST_Invalid }
pushFrom PRD
ctx (Just ByteString
dom) = PRD
ctx { praFrom :: DST
praFrom = DST
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
praSender = DST
DST_Invalid }
pushSender PRD
ctx (Just ByteString
dom) = PRD
ctx { praSender :: DST
praSender = DST
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
praResentFrom = DST
DST_Invalid }
pushResentFrom PRD
ctx (Just ByteString
dom) = PRD
ctx { praResentFrom :: DST
praResentFrom = DST
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
praResentSender = DST
DST_Invalid }
pushResentSender PRD
ctx (Just ByteString
dom)
    | PRD -> DST
praResentFrom PRD
ctx forall a. Eq a => a -> a -> Bool
== DST
DST_Zero = PRD
ctx { praResentSender :: DST
praResentSender = DST
rsender }
    | HD -> Bool
isFirstBlock (PRD -> HD
praHeader PRD
ctx)  = PRD
ctx { praResentSender :: DST
praResentSender = ByteString -> DST
DST_Valid ByteString
dom }
    | Bool
otherwise                     = PRD
ctx { praResentSender :: DST
praResentSender = DST
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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall {b}. (ByteString, b) -> Bool
rr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile forall {b}. (ByteString, b) -> Bool
end forall a b. (a -> b) -> a -> b
$ HD
hdr
  where
    end :: (ByteString, b) -> Bool
end = (forall a. Eq a => a -> a -> Bool
/= ByteString
"resent-from") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
    rr :: (ByteString, b) -> Bool
rr  = (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ByteString
"received", ByteString
"return-path"]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst