{-# LANGUAGE OverloadedStrings #-}

module Network.DomainAuth.SPF.Parser (
    parseSPF,
) where

import Control.Applicative
import Data.Attoparsec.ByteString (Parser)
import qualified Data.Attoparsec.ByteString as P
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Data.Word8
import Network.DNS (Domain)
import Network.DomainAuth.SPF.Types
import Text.Read (readMaybe)
import Prelude hiding (all)

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

parseSPF :: ByteString -> Maybe [SPF]
parseSPF :: ByteString -> Maybe [SPF]
parseSPF ByteString
inp = case Parser [SPF] -> ByteString -> Either String [SPF]
forall a. Parser a -> ByteString -> Either String a
P.parseOnly Parser [SPF]
spf ByteString
inp of
    Left String
_ -> Maybe [SPF]
forall a. Maybe a
Nothing
    Right [SPF]
res -> [SPF] -> Maybe [SPF]
forall a. a -> Maybe a
Just [SPF]
res

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

spaces1 :: Parser ()
spaces1 :: Parser ()
spaces1 = (Word8 -> Bool) -> Parser ()
P.skipWhile Word8 -> Bool
isSpace

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

spf :: Parser [SPF]
spf :: Parser [SPF]
spf = do
    Parser ()
spfPrefix
    Parser ByteString SPF -> Parser [SPF]
forall a. Parser ByteString a -> Parser ByteString [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (Parser ByteString SPF -> Parser [SPF])
-> Parser ByteString SPF -> Parser [SPF]
forall a b. (a -> b) -> a -> b
$ do
        Parser ()
spaces1
        -- modifier should be first since + is optional
        Parser ByteString SPF
modifier Parser ByteString SPF
-> Parser ByteString SPF -> Parser ByteString SPF
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString SPF
directive

spfPrefix :: Parser ()
spfPrefix :: Parser ()
spfPrefix = () () -> Parser ByteString ByteString -> Parser ()
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
P.string ByteString
"v=spf1"

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

modifier :: Parser SPF
modifier :: Parser ByteString SPF
modifier = ByteString -> SPF
SPF_Redirect (ByteString -> SPF)
-> Parser ByteString ByteString -> Parser ByteString SPF
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> Parser ByteString ByteString
P.string ByteString
"redirect=" Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
domain)

directive :: Parser SPF
directive :: Parser ByteString SPF
directive = Parser Qualifier
qualifier Parser Qualifier
-> (Qualifier -> Parser ByteString SPF) -> Parser ByteString SPF
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Qualifier -> Parser ByteString SPF
mechanism

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

qualifier :: Parser Qualifier
qualifier :: Parser Qualifier
qualifier = Qualifier -> Parser Qualifier -> Parser Qualifier
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
P.option Qualifier
Q_Pass ([Parser Qualifier] -> Parser Qualifier
forall (f :: * -> *) a. Alternative f => [f a] -> f a
P.choice [Parser Qualifier]
quals)
  where
    func :: Word8 -> a -> Parser ByteString a
func Word8
sym a
res = a
res a -> Parser ByteString Word8 -> Parser ByteString a
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Word8 -> Parser ByteString Word8
P.word8 Word8
sym
    quals :: [Parser Qualifier]
quals = (Word8 -> Qualifier -> Parser Qualifier)
-> [Word8] -> [Qualifier] -> [Parser Qualifier]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Word8 -> Qualifier -> Parser Qualifier
forall {a}. Word8 -> a -> Parser ByteString a
func (ByteString -> [Word8]
BS.unpack ByteString
qualifierSymbol) [Qualifier
forall a. Bounded a => a
minBound .. Qualifier
forall a. Bounded a => a
maxBound]

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

type Directive = Qualifier -> Parser SPF

mechanism :: Directive
mechanism :: Qualifier -> Parser ByteString SPF
mechanism Qualifier
q = [Parser ByteString SPF] -> Parser ByteString SPF
forall (f :: * -> *) a. Alternative f => [f a] -> f a
P.choice ([Parser ByteString SPF] -> Parser ByteString SPF)
-> [Parser ByteString SPF] -> Parser ByteString SPF
forall a b. (a -> b) -> a -> b
$ ((Qualifier -> Parser ByteString SPF) -> Parser ByteString SPF)
-> [Qualifier -> Parser ByteString SPF] -> [Parser ByteString SPF]
forall a b. (a -> b) -> [a] -> [b]
map ((Qualifier -> Parser ByteString SPF)
-> Qualifier -> Parser ByteString SPF
forall a b. (a -> b) -> a -> b
$ Qualifier
q) [Qualifier -> Parser ByteString SPF
ip4, Qualifier -> Parser ByteString SPF
ip6, Qualifier -> Parser ByteString SPF
all, Qualifier -> Parser ByteString SPF
address, Qualifier -> Parser ByteString SPF
mx, Qualifier -> Parser ByteString SPF
include]

ip4 :: Directive
ip4 :: Qualifier -> Parser ByteString SPF
ip4 Qualifier
q = Parser ByteString SPF -> Parser ByteString SPF
forall i a. Parser i a -> Parser i a
P.try (Parser ByteString SPF -> Parser ByteString SPF)
-> Parser ByteString SPF -> Parser ByteString SPF
forall a b. (a -> b) -> a -> b
$ do
    Maybe (AddrRange IPv4)
mip <- String -> Maybe (AddrRange IPv4)
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe (AddrRange IPv4))
-> (ByteString -> String) -> ByteString -> Maybe (AddrRange IPv4)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BS8.unpack (ByteString -> Maybe (AddrRange IPv4))
-> Parser ByteString ByteString
-> Parser ByteString (Maybe (AddrRange IPv4))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
ip4range
    case Maybe (AddrRange IPv4)
mip of
        Maybe (AddrRange IPv4)
Nothing -> String -> Parser ByteString SPF
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"ip4"
        Just AddrRange IPv4
ip -> SPF -> Parser ByteString SPF
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (SPF -> Parser ByteString SPF) -> SPF -> Parser ByteString SPF
forall a b. (a -> b) -> a -> b
$ Qualifier -> AddrRange IPv4 -> SPF
SPF_IPv4Range Qualifier
q AddrRange IPv4
ip
  where
    ip4range :: Parser ByteString ByteString
ip4range = ByteString -> Parser ByteString ByteString
P.string ByteString
"ip4:" Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Word8 -> Bool) -> Parser ByteString ByteString
P.takeWhile1 (String -> Word8 -> Bool
P.notInClass String
" ")

ip6 :: Directive
ip6 :: Qualifier -> Parser ByteString SPF
ip6 Qualifier
q = Parser ByteString SPF -> Parser ByteString SPF
forall i a. Parser i a -> Parser i a
P.try (Parser ByteString SPF -> Parser ByteString SPF)
-> Parser ByteString SPF -> Parser ByteString SPF
forall a b. (a -> b) -> a -> b
$ do
    Maybe (AddrRange IPv6)
mip <- String -> Maybe (AddrRange IPv6)
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe (AddrRange IPv6))
-> (ByteString -> String) -> ByteString -> Maybe (AddrRange IPv6)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BS8.unpack (ByteString -> Maybe (AddrRange IPv6))
-> Parser ByteString ByteString
-> Parser ByteString (Maybe (AddrRange IPv6))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
ip6range
    case Maybe (AddrRange IPv6)
mip of
        Maybe (AddrRange IPv6)
Nothing -> String -> Parser ByteString SPF
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"ip6"
        Just AddrRange IPv6
ip -> SPF -> Parser ByteString SPF
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (SPF -> Parser ByteString SPF) -> SPF -> Parser ByteString SPF
forall a b. (a -> b) -> a -> b
$ Qualifier -> AddrRange IPv6 -> SPF
SPF_IPv6Range Qualifier
q AddrRange IPv6
ip
  where
    ip6range :: Parser ByteString ByteString
ip6range = ByteString -> Parser ByteString ByteString
P.string ByteString
"ip6:" Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Word8 -> Bool) -> Parser ByteString ByteString
P.takeWhile1 (String -> Word8 -> Bool
P.notInClass String
" ")

all :: Directive
all :: Qualifier -> Parser ByteString SPF
all Qualifier
q = Parser ByteString SPF -> Parser ByteString SPF
forall i a. Parser i a -> Parser i a
P.try (Parser ByteString SPF -> Parser ByteString SPF)
-> Parser ByteString SPF -> Parser ByteString SPF
forall a b. (a -> b) -> a -> b
$ Qualifier -> SPF
SPF_All Qualifier
q SPF -> Parser ByteString ByteString -> Parser ByteString SPF
forall a b. a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
P.string ByteString
"all"

address :: Directive
address :: Qualifier -> Parser ByteString SPF
address Qualifier
q =
    Qualifier -> Maybe ByteString -> (Int, Int) -> SPF
SPF_Address Qualifier
q
        (Maybe ByteString -> (Int, Int) -> SPF)
-> Parser ByteString (Maybe ByteString)
-> Parser ByteString ((Int, Int) -> SPF)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> Parser ByteString ByteString
P.string ByteString
"a" Parser ByteString ByteString
-> Parser ByteString (Maybe ByteString)
-> Parser ByteString (Maybe ByteString)
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString (Maybe ByteString)
optionalDomain)
        Parser ByteString ((Int, Int) -> SPF)
-> Parser ByteString (Int, Int) -> Parser ByteString SPF
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString (Int, Int)
optionalMask

mx :: Directive
mx :: Qualifier -> Parser ByteString SPF
mx Qualifier
q =
    Qualifier -> Maybe ByteString -> (Int, Int) -> SPF
SPF_MX Qualifier
q
        (Maybe ByteString -> (Int, Int) -> SPF)
-> Parser ByteString (Maybe ByteString)
-> Parser ByteString ((Int, Int) -> SPF)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> Parser ByteString ByteString
P.string ByteString
"mx" Parser ByteString ByteString
-> Parser ByteString (Maybe ByteString)
-> Parser ByteString (Maybe ByteString)
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString (Maybe ByteString)
optionalDomain)
        Parser ByteString ((Int, Int) -> SPF)
-> Parser ByteString (Int, Int) -> Parser ByteString SPF
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString (Int, Int)
optionalMask

include :: Directive
include :: Qualifier -> Parser ByteString SPF
include Qualifier
q = Qualifier -> ByteString -> SPF
SPF_Include Qualifier
q (ByteString -> SPF)
-> Parser ByteString ByteString -> Parser ByteString SPF
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> Parser ByteString ByteString
P.string ByteString
"include:" Parser ByteString ByteString
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
domain)

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

domain :: Parser Domain
domain :: Parser ByteString ByteString
domain = (Word8 -> Bool) -> Parser ByteString ByteString
P.takeWhile1 (String -> Word8 -> Bool
P.inClass String
"a-zA-Z0-9_.-")

optionalDomain :: Parser (Maybe Domain)
optionalDomain :: Parser ByteString (Maybe ByteString)
optionalDomain = Maybe ByteString
-> Parser ByteString (Maybe ByteString)
-> Parser ByteString (Maybe ByteString)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
P.option Maybe ByteString
forall a. Maybe a
Nothing (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> Parser ByteString ByteString
-> Parser ByteString (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Parser ByteString Word8
P.word8 Word8
_colon Parser ByteString Word8
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
domain))

mask :: Parser Int
mask :: Parser Int
mask = String -> Int
forall a. Read a => String -> a
read (String -> Int) -> (ByteString -> String) -> ByteString -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BS8.unpack (ByteString -> Int) -> Parser ByteString ByteString -> Parser Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser ByteString ByteString
P.takeWhile1 (String -> Word8 -> Bool
P.inClass String
"0-9")

optionalMask :: Parser (Int, Int)
optionalMask :: Parser ByteString (Int, Int)
optionalMask = Parser ByteString (Int, Int) -> Parser ByteString (Int, Int)
forall i a. Parser i a -> Parser i a
P.try Parser ByteString (Int, Int)
both Parser ByteString (Int, Int)
-> Parser ByteString (Int, Int) -> Parser ByteString (Int, Int)
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString (Int, Int) -> Parser ByteString (Int, Int)
forall i a. Parser i a -> Parser i a
P.try Parser ByteString (Int, Int)
v4 Parser ByteString (Int, Int)
-> Parser ByteString (Int, Int) -> Parser ByteString (Int, Int)
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString (Int, Int) -> Parser ByteString (Int, Int)
forall i a. Parser i a -> Parser i a
P.try Parser ByteString (Int, Int)
v6 Parser ByteString (Int, Int)
-> Parser ByteString (Int, Int) -> Parser ByteString (Int, Int)
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString (Int, Int)
none
  where
    both :: Parser ByteString (Int, Int)
both = (,) (Int -> Int -> (Int, Int))
-> Parser Int -> Parser ByteString (Int -> (Int, Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Int
ipv4Mask Parser ByteString (Int -> (Int, Int))
-> Parser Int -> Parser ByteString (Int, Int)
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int
ipv6Mask
    v4 :: Parser ByteString (Int, Int)
v4 = Parser Int
ipv4Mask Parser Int
-> (Int -> Parser ByteString (Int, Int))
-> Parser ByteString (Int, Int)
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
l4 -> (Int, Int) -> Parser ByteString (Int, Int)
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
l4, Int
128)
    v6 :: Parser ByteString (Int, Int)
v6 = Parser Int
ipv6Mask Parser Int
-> (Int -> Parser ByteString (Int, Int))
-> Parser ByteString (Int, Int)
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
l6 -> (Int, Int) -> Parser ByteString (Int, Int)
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
32, Int
l6)
    none :: Parser ByteString (Int, Int)
none = (Int, Int) -> Parser ByteString (Int, Int)
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
32, Int
128)

ipv4Mask :: Parser Int
ipv4Mask :: Parser Int
ipv4Mask = Word8 -> Parser ByteString Word8
P.word8 Word8
_slash Parser ByteString Word8 -> Parser Int -> Parser Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
mask

ipv6Mask :: Parser Int
ipv6Mask :: Parser Int
ipv6Mask = ByteString -> Parser ByteString ByteString
P.string ByteString
"//" Parser ByteString ByteString -> Parser Int -> Parser Int
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
mask