{-# 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 (Eq, Show)

  | Abstract type for context to decide PRD(purported responsible domain )
--   according to RFC 4407.
data PRD = PRD {
    praFrom         :: DST
  , praSender       :: DST
  , praResentFrom   :: DST
  , praResentSender :: DST
  , praHeader       :: HD
  } deriving Show

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

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

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

  | Deciding PRD from the RPD context .
--
-- >>> let maddr1 = ""
  > > > let maddr2 = "  "
-- >>> let maddr3 = ""
-- >>> let maddr4 = ""
-- >>> decidePRD (pushPRD "from" "" 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 ctx =
    let jds = [ praResentSender ctx
              , praResentFrom ctx
              , praSender ctx
              , praFrom ctx
              ]
    in foldl' mplus mzero $ map toMaybe jds

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

toMaybe :: DST -> Maybe Domain
toMaybe (DST_Valid d) = Just d
toMaybe _             = Nothing

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

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

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

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

pushResentSender :: PRD -> Maybe Domain -> PRD
pushResentSender ctx Nothing        = ctx { praResentSender = DST_Invalid }
pushResentSender ctx (Just dom)
    | praResentFrom ctx == DST_Zero = ctx { praResentSender = rsender }
    | isFirstBlock (praHeader ctx)  = ctx { praResentSender = DST_Valid dom }
    | otherwise                     = ctx { praResentSender = DST_Invalid }
  where
    rsender = case praResentSender ctx of
        DST_Zero    -> DST_Valid dom
        DST_Valid d -> DST_Valid d
        DST_Invalid -> DST_Invalid

isFirstBlock :: HD -> Bool
isFirstBlock hdr = all rr . takeWhile end $ hdr
  where
    end = (/= "resent-from") . fst
    rr  = (`notElem` ["received", "return-path"]) . fst

# LANGUAGE OverloadedStrings #
 | Purported Responsible Domain, RFC 4407.
--------------------------------------------------------------
   according to RFC 4407.
--------------------------------------------------------------

 >>> let maddr1 = ""
 >>> let maddr3 = ""
 >>> let maddr4 = ""
 >>> decidePRD (pushPRD "from" "" 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"

 >>> decideFrom (pushPRD "from" "" initialPRD)
 Just "alice.example.jp"
--------------------------------------------------------------


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 (Eq, Show)

  | Abstract type for context to decide PRD(purported responsible domain )
data PRD = PRD {
    praFrom         :: DST
  , praSender       :: DST
  , praResentFrom   :: DST
  , praResentSender :: DST
  , praHeader       :: HD
  } deriving Show

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


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

  | Deciding PRD from the RPD context .
  > > > let maddr2 = "  "

decidePRD :: PRD -> Maybe Domain
decidePRD ctx =
    let jds = [ praResentSender ctx
              , praResentFrom ctx
              , praSender ctx
              , praFrom ctx
              ]
    in foldl' mplus mzero $ map toMaybe jds

  | Taking the value of From : from the RPD context .
decideFrom :: PRD -> Maybe Domain
decideFrom = toMaybe . praFrom

toMaybe :: DST -> Maybe Domain
toMaybe (DST_Valid d) = Just d
toMaybe _             = Nothing


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

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

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

pushResentSender :: PRD -> Maybe Domain -> PRD
pushResentSender ctx Nothing        = ctx { praResentSender = DST_Invalid }
pushResentSender ctx (Just dom)
    | praResentFrom ctx == DST_Zero = ctx { praResentSender = rsender }
    | isFirstBlock (praHeader ctx)  = ctx { praResentSender = DST_Valid dom }
    | otherwise                     = ctx { praResentSender = DST_Invalid }
  where
    rsender = case praResentSender ctx of
        DST_Zero    -> DST_Valid dom
        DST_Valid d -> DST_Valid d
        DST_Invalid -> DST_Invalid

isFirstBlock :: HD -> Bool
isFirstBlock hdr = all rr . takeWhile end $ hdr
  where
    end = (/= "resent-from") . fst
    rr  = (`notElem` ["received", "return-path"]) . fst
