Eval.hs

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

import Control.Exception as E
import Data.IP
import Data.Maybe
import Network.DNS (Domain)
import Network.DomainAuth.SPF.Resolver
import Network.DomainAuth.SPF.Types
import Network.DomainAuth.Types
import System.IO.Error

-- |  Limit for SPF authentication.
data Limit = Limit
    { limit :: Int
    -- ^ How many DNS-querying terms (\"a\", \"mx\", \"include\" and
    --   \"redirect\") are allowed. 'DAPermError' is returned if exceeded.
    , ipv4_masklen :: Int
    -- ^ Ignoring IPv4 range whose mask length is shorter than this.
    , ipv6_masklen :: Int
    -- ^ Ignoring IPv6 range whose mask length is shorter than this.
    , reject_plus_all :: Bool
    -- ^ Whether or not \"+all\" is rejected.
    }
    deriving (Eq, Show)

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

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

-- | Running SPF with the given lookup functions.
runSPFWith :: Limit -> SpfLookup -> Domain -> IP -> IO DAResult
runSPFWith lim lk dom ip = do
    ctx <- newSpfCtx lk (limit lim)
    (resolveSPF ctx False dom ip >>= evalSPF lim ip) `E.catch` spfErrorHandle

spfErrorHandle :: IOError -> IO DAResult
spfErrorHandle e = case ioeGetErrorString e of
    "TempError" -> return DATempError
    "PermError" -> return DAPermError
    _ -> return DANone

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

-- | DNS lookup limits are enforced in "Network.DomainAuth.SPF.Resolver".
evalSPF :: Limit -> IP -> [IO SpfSeq] -> IO DAResult
evalSPF lim ip ss = fromJust <$> evalspf lim ip ss

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

evalspf :: Limit -> IP -> [IO SpfSeq] -> IO (Maybe DAResult)
evalspf _ _ [] = return (Just DANeutral) -- default result
evalspf lim ip (s : ss) = do
    mres <- eval lim ip s
    case mres of
        Nothing -> evalspf lim ip ss
        res -> return res

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

eval :: Limit -> IP -> IO SpfSeq -> IO (Maybe DAResult)
eval lim ip is = do
    s <- is
    case s of
        SS_All q ->
            if q == Q_Pass && reject_plus_all lim
                then result DAPermError
                else ret q
        SS_IPv4Range q ipr
            | nastyMask4 lim ipr -> result DAPermError
            | ipv4 ip `isMatchedTo` ipr -> ret q
            | otherwise -> continue
        SS_IPv4Ranges q iprs
            | any (nastyMask4 lim) iprs -> result DAPermError
            | any (ipv4 ip `isMatchedTo`) iprs -> ret q
            | otherwise -> continue
        SS_IPv6Range q ipr
            | nastyMask6 lim ipr -> result DAPermError
            | ipv6 ip `isMatchedTo` ipr -> ret q
            | otherwise -> continue
        SS_IPv6Ranges q iprs
            | any (nastyMask6 lim) iprs -> result DAPermError
            | any (ipv6 ip `isMatchedTo`) iprs -> ret q
            | otherwise -> continue
        SS_IF_Pass q ss -> do
            r <- evalspf lim ip ss
            if r == Just DAPass
                then ret q
                else continue
        SS_SpfSeq ss -> evalspf lim ip ss
  where
    ret = return . Just . toEnum . fromEnum
    result = return . Just
    continue = return Nothing
    nastyMask4 st ipr = mlen ipr < ipv4_masklen st
    nastyMask6 st ipr = mlen ipr < ipv6_masklen st