{-# 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, 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 Prelude hiding (all)
import Text.Read (readMaybe)

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

parseSPF :: ByteString -> Maybe [SPF]
parseSPF :: ByteString -> Maybe [SPF]
parseSPF ByteString
inp = case forall a. Parser a -> ByteString -> Either String a
P.parseOnly Parser [SPF]
spf ByteString
inp of
  Left String
_    -> forall a. Maybe a
Nothing
  Right [SPF]
res -> 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
         forall (f :: * -> *) a. Alternative f => f a -> f [a]
some forall a b. (a -> b) -> a -> b
$ do Parser ()
spaces1
                    -- modifier should be first since + is optional
                   Parser ByteString SPF
modifier forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString SPF
directive

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

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

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

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

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

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

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

type Directive = Qualifier -> Parser SPF

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

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

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

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

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

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

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

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

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

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

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

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

ipv4Mask :: Parser Int
ipv4Mask :: Parser Int
ipv4Mask = Word8 -> Parser Word8
P.word8 Word8
_slash 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
P.string ByteString
"//" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
mask