{-# LANGUAGE OverloadedStrings #-}
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)
data PRD = PRD
{ PRD -> DST
praFrom :: DST
, PRD -> DST
praSender :: DST
, PRD -> DST
praResentFrom :: DST
, PRD -> DST
praResentSender :: DST
, :: 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)
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 = []
}
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}
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
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