module Network.DomainAuth.SPF.Eval (
    evalSPF
  , Limit(..)
  , defaultLimit
  ) where

import Data.IORef
import Data.IP
import Data.Maybe
import Network.DomainAuth.SPF.Types
import Network.DomainAuth.Types

-- |  Limit for SPF authentication.
data Limit = Limit {
    -- | How many \"redirect\"/\"include\" should be followed.
    --   'DAPermError' is returned if reached to this limit.
    Limit -> Int
limit :: Int
    -- | Ignoring IPv4 range whose mask length is shorter than this.
  , Limit -> Int
ipv4_masklen :: Int
    -- | Ignoring IPv6 range whose mask length is shorter than this.
  , Limit -> Int
ipv6_masklen :: Int
    -- | Whether or not \"+all\" is rejected.
  , Limit -> Bool
reject_plus_all :: Bool
  } deriving (Limit -> Limit -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Limit -> Limit -> Bool
$c/= :: Limit -> Limit -> Bool
== :: Limit -> Limit -> Bool
$c== :: Limit -> Limit -> Bool
Eq, Int -> Limit -> ShowS
[Limit] -> ShowS
Limit -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Limit] -> ShowS
$cshowList :: [Limit] -> ShowS
show :: Limit -> String
$cshow :: Limit -> String
showsPrec :: Int -> Limit -> ShowS
$cshowsPrec :: Int -> Limit -> ShowS
Show)

-- | Default value for 'Limit'.
--
-- >>> defaultLimit
-- Limit {limit = 10, ipv4_masklen = 16, ipv6_masklen = 48, reject_plus_all = True}

defaultLimit :: Limit
defaultLimit :: Limit
defaultLimit = Limit {
    limit :: Int
limit = Int
10
  , ipv4_masklen :: Int
ipv4_masklen = Int
16
  , ipv6_masklen :: Int
ipv6_masklen = Int
48
  , reject_plus_all :: Bool
reject_plus_all = Bool
True
  }

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

evalSPF :: Limit -> IP -> [IO SpfSeq] -> IO DAResult
evalSPF :: Limit -> IP -> [IO SpfSeq] -> IO DAResult
evalSPF Limit
lim IP
ip [IO SpfSeq]
ss = do
    IORef Int
ref <- forall a. a -> IO (IORef a)
newIORef (Int
0 :: Int)
    forall a. HasCallStack => Maybe a -> a
fromJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Int -> Limit -> IP -> [IO SpfSeq] -> IO (Maybe DAResult)
evalspf IORef Int
ref Limit
lim IP
ip [IO SpfSeq]
ss

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

evalspf :: IORef Int -> Limit -> IP -> [IO SpfSeq] -> IO (Maybe DAResult)
evalspf :: IORef Int -> Limit -> IP -> [IO SpfSeq] -> IO (Maybe DAResult)
evalspf IORef Int
_ Limit
_ IP
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just DAResult
DANeutral) -- default result
evalspf IORef Int
ref Limit
lim IP
ip (IO SpfSeq
s:[IO SpfSeq]
ss) = do
    Int
cnt <- forall a. IORef a -> IO a
readIORef IORef Int
ref
    if Int
cnt forall a. Ord a => a -> a -> Bool
> Limit -> Int
limit Limit
lim
       then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just DAResult
DAPermError) -- reached the limit
       else do
           Maybe DAResult
mres <- IORef Int -> Limit -> IP -> IO SpfSeq -> IO (Maybe DAResult)
eval IORef Int
ref Limit
lim IP
ip IO SpfSeq
s
           case Maybe DAResult
mres of
               Maybe DAResult
Nothing  -> IORef Int -> Limit -> IP -> [IO SpfSeq] -> IO (Maybe DAResult)
evalspf IORef Int
ref Limit
lim IP
ip [IO SpfSeq]
ss
               Maybe DAResult
res      -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe DAResult
res

----------------------------------------------------------------
-- Follow N of redirect/include. But the last one is not
-- evaluated.

eval :: IORef Int -> Limit -> IP -> IO SpfSeq -> IO (Maybe DAResult)
eval :: IORef Int -> Limit -> IP -> IO SpfSeq -> IO (Maybe DAResult)
eval IORef Int
ref Limit
lim IP
ip IO SpfSeq
is = do
    Int
cnt <- forall a. IORef a -> IO a
readIORef IORef Int
ref
    SpfSeq
s <- IO SpfSeq
is
    case SpfSeq
s of
      SS_All Qualifier
q -> if Qualifier
q forall a. Eq a => a -> a -> Bool
== Qualifier
Q_Pass Bool -> Bool -> Bool
&& Limit -> Bool
reject_plus_all Limit
lim
                  then forall {a}. a -> IO (Maybe a)
result DAResult
DAPermError
                  else Qualifier -> IO (Maybe DAResult)
ret Qualifier
q
      SS_IPv4Range Qualifier
q AddrRange IPv4
ipr
           | forall {a}. Limit -> AddrRange a -> Bool
nastyMask4 Limit
lim AddrRange IPv4
ipr        -> forall {a}. a -> IO (Maybe a)
result DAResult
DAPermError
           | IP -> IPv4
ipv4 IP
ip forall a. Addr a => a -> AddrRange a -> Bool
`isMatchedTo` AddrRange IPv4
ipr -> Qualifier -> IO (Maybe DAResult)
ret Qualifier
q
           | Bool
otherwise                 -> forall {a}. IO (Maybe a)
continue
      SS_IPv4Ranges Qualifier
q [AddrRange IPv4]
iprs
           | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall {a}. Limit -> AddrRange a -> Bool
nastyMask4 Limit
lim) [AddrRange IPv4]
iprs        -> forall {a}. a -> IO (Maybe a)
result DAResult
DAPermError
           | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (IP -> IPv4
ipv4 IP
ip forall a. Addr a => a -> AddrRange a -> Bool
`isMatchedTo`) [AddrRange IPv4]
iprs -> Qualifier -> IO (Maybe DAResult)
ret Qualifier
q
           | Bool
otherwise                        -> forall {a}. IO (Maybe a)
continue
      SS_IPv6Range Qualifier
q AddrRange IPv6
ipr
           | forall {a}. Limit -> AddrRange a -> Bool
nastyMask6 Limit
lim AddrRange IPv6
ipr        -> forall {a}. a -> IO (Maybe a)
result DAResult
DAPermError
           | IP -> IPv6
ipv6 IP
ip forall a. Addr a => a -> AddrRange a -> Bool
`isMatchedTo` AddrRange IPv6
ipr -> Qualifier -> IO (Maybe DAResult)
ret Qualifier
q
           | Bool
otherwise                 -> forall {a}. IO (Maybe a)
continue
      SS_IPv6Ranges Qualifier
q [AddrRange IPv6]
iprs
           | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall {a}. Limit -> AddrRange a -> Bool
nastyMask6 Limit
lim) [AddrRange IPv6]
iprs        -> forall {a}. a -> IO (Maybe a)
result DAResult
DAPermError
           | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (IP -> IPv6
ipv6 IP
ip forall a. Addr a => a -> AddrRange a -> Bool
`isMatchedTo`) [AddrRange IPv6]
iprs -> Qualifier -> IO (Maybe DAResult)
ret Qualifier
q
           | Bool
otherwise                        -> forall {a}. IO (Maybe a)
continue
      SS_IF_Pass Qualifier
q [IO SpfSeq]
ss -> do
          forall a. IORef a -> a -> IO ()
writeIORef IORef Int
ref (Int
cnt forall a. Num a => a -> a -> a
+ Int
1)
          Maybe DAResult
r <- IORef Int -> Limit -> IP -> [IO SpfSeq] -> IO (Maybe DAResult)
evalspf IORef Int
ref Limit
lim IP
ip [IO SpfSeq]
ss
          if Maybe DAResult
r forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just DAResult
DAPass
            then Qualifier -> IO (Maybe DAResult)
ret Qualifier
q
            else forall {a}. IO (Maybe a)
continue
      SS_SpfSeq [IO SpfSeq]
ss -> do
          forall a. IORef a -> a -> IO ()
writeIORef IORef Int
ref (Int
cnt forall a. Num a => a -> a -> a
+ Int
1)
          IORef Int -> Limit -> IP -> [IO SpfSeq] -> IO (Maybe DAResult)
evalspf IORef Int
ref Limit
lim IP
ip [IO SpfSeq]
ss
  where
    ret :: Qualifier -> IO (Maybe DAResult)
ret = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum
    result :: a -> IO (Maybe a)
result = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just
    continue :: IO (Maybe a)
continue = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
    nastyMask4 :: Limit -> AddrRange a -> Bool
nastyMask4 Limit
st AddrRange a
ipr = forall a. AddrRange a -> Int
mlen AddrRange a
ipr forall a. Ord a => a -> a -> Bool
< Limit -> Int
ipv4_masklen Limit
st
    nastyMask6 :: Limit -> AddrRange a -> Bool
nastyMask6 Limit
st AddrRange a
ipr = forall a. AddrRange a -> Int
mlen AddrRange a
ipr forall a. Ord a => a -> a -> Bool
< Limit -> Int
ipv6_masklen Limit
st