345 lines
15 KiB
Plaintext
345 lines
15 KiB
Plaintext
module App.Validation.DNS where
|
|
|
|
import Prelude (apply, between, bind, map, pure, ($), (-), (<), (<>), (==))
|
|
|
|
import Control.Alt ((<|>))
|
|
import Data.Array as A
|
|
import Data.Either (Either(..))
|
|
import Data.Maybe (Maybe(..), maybe, fromMaybe)
|
|
import Data.String.CodeUnits as CU
|
|
import Data.String as S
|
|
import Data.Validation.Semigroup (V, invalid, toEither)
|
|
|
|
import App.Type.ResourceRecord (ResourceRecord, emptyRR, Mechanism, Modifier)
|
|
import App.Type.ResourceRecord (MechanismType(..), ModifierType(..)) as RR
|
|
import GenericParser.SomeParsers as SomeParsers
|
|
import GenericParser.Parser as G
|
|
import GenericParser.DomainParser.Common (DomainError) as DomainParser
|
|
import GenericParser.DomainParser (sub_eof) as DomainParser
|
|
import GenericParser.IPAddress as IPAddress
|
|
import GenericParser.RFC5234 as RFC5234
|
|
|
|
import App.Type.DKIM as DKIM
|
|
import App.Type.DMARC as DMARC
|
|
|
|
-- | **History:**
|
|
-- | The module once used dedicated types for each type of RR.
|
|
-- | That comes with several advantages.
|
|
-- | First, type verification was a thing, and function were dedicated to a certain type of record.
|
|
-- | Second, these dedicated types used strings for their fields,
|
|
-- | which simplifies the typing when dealing with forms.
|
|
-- | Finally, the validation was a way to convert dedicated types (used in forms)
|
|
-- | to the general type (used for network serialization).
|
|
-- | This ensures each resource record is verified before being sent to `dnsmanagerd`.
|
|
-- |
|
|
-- | The problem is that, with dedicated types, you are then required to have dedicated functions.
|
|
-- | Conversion functions are also required.
|
|
-- |
|
|
-- | Maybe the code will change again in the future, but for now it will be enough.
|
|
|
|
data Error
|
|
= UNKNOWN
|
|
| VEIPv4 (G.Error IPAddress.IPv4Error)
|
|
| VEIPv6 (G.Error IPAddress.IPv6Error)
|
|
| VEName (G.Error DomainParser.DomainError)
|
|
| VETTL Int Int Int
|
|
| VETXT (G.Error TXTError)
|
|
| VECNAME (G.Error DomainParser.DomainError)
|
|
| VENS (G.Error DomainParser.DomainError)
|
|
| VEMX (G.Error DomainParser.DomainError)
|
|
| VEPriority Int Int Int
|
|
| VESRV (G.Error DomainParser.DomainError)
|
|
| VEProtocol (G.Error ProtocolError)
|
|
| VEPort Int Int Int
|
|
| VEWeight Int Int Int
|
|
| VEDMARCpct Int Int Int
|
|
| VEDMARCri Int Int Int
|
|
|
|
-- SPF
|
|
| VESPFMechanismName (G.Error DomainParser.DomainError)
|
|
| VESPFMechanismIPv4 (G.Error IPAddress.IPv4Error)
|
|
| VESPFMechanismIPv6 (G.Error IPAddress.IPv6Error)
|
|
|
|
| VESPFModifierName (G.Error DomainParser.DomainError)
|
|
|
|
| DKIMInvalidKeySize Int Int
|
|
|
|
type AVErrors = Array Error
|
|
|
|
-- | Current default values.
|
|
min_ttl = 30 :: Int
|
|
max_ttl = 86000 :: Int
|
|
max_txt = 500 :: Int
|
|
min_priority = 0 :: Int
|
|
max_priority = 65535 :: Int
|
|
min_port = 0 :: Int
|
|
max_port = 65535 :: Int
|
|
min_weight = 0 :: Int
|
|
max_weight = 65535 :: Int
|
|
|
|
-- Functions handling network-related structures (ResourceRecord).
|
|
|
|
type RRPriority = Maybe Int
|
|
type RRPort = Maybe Int
|
|
type RRProtocol = Maybe String
|
|
type RRWeight = Maybe Int
|
|
type RRMname = Maybe String
|
|
type RRRname = Maybe String
|
|
type RRSerial = Maybe Int
|
|
type RRRefresh = Maybe Int
|
|
type RRRetry = Maybe Int
|
|
type RRExpire = Maybe Int
|
|
type RRMinttl = Maybe Int
|
|
|
|
data TXTError
|
|
= TXTInvalidCharacter
|
|
| TXTTooLong Int Int -- max current
|
|
-- | TODO: `txt_parser` is currently accepting any printable character (`vchar + sp`).
|
|
txt_parser :: G.Parser TXTError String
|
|
txt_parser = do pos <- G.current_position
|
|
v <- A.many (RFC5234.vchar <|> RFC5234.sp)
|
|
e <- G.tryMaybe SomeParsers.eof
|
|
pos2 <- G.current_position
|
|
case e of
|
|
Nothing -> G.errorParser $ Just TXTInvalidCharacter
|
|
Just _ -> do
|
|
let nbchar = pos2 - pos
|
|
if nbchar < max_txt
|
|
then pure $ CU.fromCharArray v
|
|
else G.Parser \_ -> G.failureError pos (Just $ TXTTooLong max_txt nbchar)
|
|
|
|
-- | `parse` enables to run any parser based on `GenericParser` and provide a validation error.
|
|
-- | The actual validation error contains the parser's error including the position.
|
|
parse :: forall e v. G.Parser e v -> String -> ((G.Error e) -> Error) -> V (Array Error) v
|
|
parse (G.Parser p) str c = case p { string: str, position: 0 } of
|
|
Left x -> invalid $ [c x]
|
|
Right x -> pure x.result
|
|
|
|
validationA :: ResourceRecord -> V (Array Error) ResourceRecord
|
|
validationA form = ado
|
|
name <- parse DomainParser.sub_eof form.name VEName
|
|
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
|
target <- parse IPAddress.ipv4 form.target VEIPv4
|
|
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "A", name = name, ttl = ttl, target = target
|
|
, token = form.token }
|
|
|
|
validationAAAA :: ResourceRecord -> V (Array Error) ResourceRecord
|
|
validationAAAA form = ado
|
|
name <- parse DomainParser.sub_eof form.name VEName
|
|
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
|
-- use read_input to get unaltered input (the IPv6 parser expands the input)
|
|
target <- parse (G.read_input IPAddress.ipv6) form.target VEIPv6
|
|
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "AAAA", name = name, ttl = ttl, target = target
|
|
, token = form.token }
|
|
|
|
validationTXT :: ResourceRecord -> V (Array Error) ResourceRecord
|
|
validationTXT form = ado
|
|
name <- parse DomainParser.sub_eof form.name VEName
|
|
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
|
target <- parse txt_parser form.target VETXT
|
|
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "TXT", name = name, ttl = ttl, target = target }
|
|
|
|
validationCNAME :: ResourceRecord -> V (Array Error) ResourceRecord
|
|
validationCNAME form = ado
|
|
name <- parse DomainParser.sub_eof form.name VEName
|
|
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
|
target <- parse DomainParser.sub_eof form.target VECNAME
|
|
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "CNAME", name = name, ttl = ttl, target = target }
|
|
|
|
validationNS :: ResourceRecord -> V (Array Error) ResourceRecord
|
|
validationNS form = ado
|
|
name <- parse DomainParser.sub_eof form.name VEName
|
|
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
|
target <- parse DomainParser.sub_eof form.target VENS
|
|
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "NS", name = name, ttl = ttl, target = target }
|
|
|
|
data ProtocolError
|
|
= InvalidProtocol
|
|
|
|
protocol_parser :: G.Parser ProtocolError String
|
|
protocol_parser = do
|
|
G.string "tcp" <|> G.string "udp" G.<:> \_ -> InvalidProtocol
|
|
|
|
is_between :: Int -> Int -> Int -> (Int -> Int -> Int -> Error) -> V (Array Error) Int
|
|
is_between min max n ve = if between min max n
|
|
then pure n
|
|
else invalid [ve min max n]
|
|
|
|
validationMX :: ResourceRecord -> V (Array Error) ResourceRecord
|
|
validationMX form = ado
|
|
name <- parse DomainParser.sub_eof form.name VEName
|
|
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
|
target <- parse DomainParser.sub_eof form.target VEMX
|
|
priority <- is_between min_priority max_priority (maybe 0 id form.priority) VEPriority
|
|
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "MX"
|
|
, name = name, ttl = ttl, target = target, priority = Just priority }
|
|
|
|
validationSRV :: ResourceRecord -> V (Array Error) ResourceRecord
|
|
validationSRV form = ado
|
|
name <- parse DomainParser.sub_eof form.name VEName
|
|
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
|
target <- parse DomainParser.sub_eof form.target VESRV
|
|
priority <- is_between min_priority max_priority (maybe 0 id form.priority) VEPriority
|
|
protocol <- parse protocol_parser (maybe "" id form.protocol) VEProtocol
|
|
port <- is_between min_port max_port (maybe 0 id form.port) VEPort
|
|
weight <- is_between min_weight max_weight (maybe 0 id form.weight) VEWeight
|
|
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "SRV"
|
|
, name = name, ttl = ttl, target = target
|
|
, priority = Just priority, port = Just port, protocol = Just protocol, weight = Just weight }
|
|
|
|
-- My version of "map" lol.
|
|
verification_loop :: forall a e. (a -> V (Array e) a) -> Array a -> V (Array e) (Array a)
|
|
verification_loop _ [] = pure []
|
|
verification_loop f arr =
|
|
case A.head arr, A.tail arr of
|
|
Nothing, _ -> pure []
|
|
Just value, tail -> ado
|
|
v <- f value
|
|
following <- verification_loop f $ maybe [] id tail
|
|
in [v] <> following
|
|
|
|
first :: forall a b. a -> b -> a
|
|
first a _ = a
|
|
|
|
or_nothing :: forall e. G.Parser e String -> G.Parser e String
|
|
or_nothing p = do v <- G.tryMaybe p
|
|
e <- G.tryMaybe SomeParsers.eof
|
|
case v, e of
|
|
Just value, _ -> pure value
|
|
_, Just _ -> pure ""
|
|
Nothing, Nothing -> p -- at least give the right error results
|
|
|
|
-- | `validate_SPF_mechanism` validates the different values for each mechanism.
|
|
-- | A and MX can both either doesn't have a value or a domain name.
|
|
-- | EXISTS requires a domain name.
|
|
-- |
|
|
-- | **What differs from RFC7208**:
|
|
-- | Some features of the mechanisms described in RFC7208 are lacking.
|
|
-- | For instance, INCLUDE, A, MX, PTR and EXISTS accept domain *specs* not simply domain *names*.
|
|
-- | Also, some of them should accept a CIDR, which currently isn't a thing.
|
|
-- |
|
|
-- | TODO: I don't intend to implement the full RFC7208, but accepting CIDR can be done.
|
|
validate_SPF_mechanism :: Mechanism -> V (Array Error) Mechanism
|
|
validate_SPF_mechanism m = case m.t of
|
|
-- RFC: `a = "a" [ ":" domain-spec ] [ dual-cidr-length ]`
|
|
RR.A -> test (or_nothing DomainParser.sub_eof) VESPFMechanismName
|
|
|
|
-- RFC: `mx = "mx" [ ":" domain-spec ] [ dual-cidr-length ]`
|
|
RR.MX -> test (or_nothing DomainParser.sub_eof) VESPFMechanismName
|
|
|
|
-- RFC: `exists = "exists" ":" domain-spec`
|
|
RR.EXISTS -> test DomainParser.sub_eof VESPFMechanismName
|
|
|
|
-- RFC: `ptr = "ptr" [ ":" domain-spec ]`
|
|
RR.PTR -> test (or_nothing DomainParser.sub_eof) VESPFMechanismName
|
|
|
|
-- RFC: `ip4 = "ip4" ":" ip4-network [ ip4-cidr-length ]`
|
|
RR.IP4 -> test (IPAddress.ipv4_range <|> IPAddress.ipv4) VESPFMechanismIPv4
|
|
|
|
-- RFC: `ip6 = "ip6" ":" ip6-network [ ip6-cidr-length ]`
|
|
RR.IP6 -> test (IPAddress.ipv6_range <|> IPAddress.ipv6) VESPFMechanismIPv6
|
|
|
|
-- RFC: `include = "include" ":" domain-spec`
|
|
RR.INCLUDE -> test DomainParser.sub_eof VESPFMechanismName
|
|
|
|
where
|
|
test :: forall e. G.Parser e String -> ((G.Error e) -> Error) -> V (Array Error) Mechanism
|
|
test p e = ado
|
|
name <- parse p m.v e
|
|
in first m name -- name is discarded
|
|
|
|
validate_SPF_modifier :: Modifier -> V (Array Error) Modifier
|
|
validate_SPF_modifier m = case m.t of
|
|
RR.EXP -> ado
|
|
name <- parse DomainParser.sub_eof m.v VESPFModifierName
|
|
in first m name -- name is discarded
|
|
RR.REDIRECT -> ado
|
|
name <- parse DomainParser.sub_eof m.v VESPFModifierName
|
|
in first m name -- name is discarded
|
|
|
|
validationSPF :: ResourceRecord -> V (Array Error) ResourceRecord
|
|
validationSPF form = ado
|
|
name <- parse DomainParser.sub_eof form.name VEName
|
|
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
|
mechanisms <- verification_loop validate_SPF_mechanism (maybe [] id form.mechanisms)
|
|
modifiers <- verification_loop validate_SPF_modifier (maybe [] id form.modifiers)
|
|
-- No need to validate the target, actually, it will be completely discarded.
|
|
-- The different specific entries replace `target` completely.
|
|
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "SPF"
|
|
, name = name, ttl = ttl, target = "" -- `target` is discarded!
|
|
, v = form.v, mechanisms = Just mechanisms
|
|
, modifiers = Just modifiers, q = form.q }
|
|
|
|
-- | Accepted RSA key sizes = 2048 or 4096 bits, 256 bits for ED25519.
|
|
-- |
|
|
-- | Since the public key representation for the RSA algorithm is in PKCS format (RFC 5958)
|
|
-- | then converted in PEM (RFC 7468), and knowing this format enables some optional parameters,
|
|
-- | it is not possible to expect an exact size for the public key input.
|
|
-- | Consequently, we expect *at least* an input of 250 bytes for public key, loosely leading
|
|
-- | to accept key sizes of at least 2048 bits. Maximum allowed key size is also arbitrary.
|
|
rsa_min_key_size = 250 :: Int
|
|
rsa_max_key_size = 1000 :: Int
|
|
|
|
-- | Contrary to RSA, ED25519 doesn't use a PEM-converted PKCS representation to exchange
|
|
-- | public keys, and the key size is 256 bits (32 bytes).
|
|
-- | This key is converted directly in base64, leading to a simple 44-byte key representation.
|
|
ed25519_key_size = 44 :: Int
|
|
|
|
verify_public_key :: DKIM.SignatureAlgorithm -> DKIM.PublicKey -> V (Array Error) DKIM.PublicKey
|
|
verify_public_key signalgo key = case signalgo of
|
|
DKIM.RSA -> ado
|
|
k <- if between rsa_min_key_size rsa_max_key_size (S.length key)
|
|
then pure key
|
|
else invalid [DKIMInvalidKeySize rsa_min_key_size rsa_max_key_size]
|
|
in k
|
|
DKIM.ED25519 -> ado
|
|
k <- if S.length key == ed25519_key_size
|
|
then pure key
|
|
else invalid [DKIMInvalidKeySize ed25519_key_size ed25519_key_size]
|
|
in k
|
|
|
|
validationDKIM :: ResourceRecord -> V (Array Error) ResourceRecord
|
|
validationDKIM form =
|
|
let dkim = fromMaybe DKIM.emptyDKIMRR form.dkim
|
|
in ado
|
|
name <- parse DomainParser.sub_eof form.name VEName
|
|
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
|
-- TODO: v n
|
|
p <- verify_public_key (fromMaybe DKIM.RSA dkim.k) dkim.p
|
|
-- No need to validate the target, actually, it will be completely discarded.
|
|
-- The different specific entries replace `target` completely.
|
|
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "DKIM"
|
|
, name = name, ttl = ttl, target = "" -- `target` is discarded!
|
|
, dkim = Just $ dkim { p = p } }
|
|
|
|
validationDMARC :: ResourceRecord -> V (Array Error) ResourceRecord
|
|
validationDMARC form =
|
|
let dmarc = fromMaybe DMARC.emptyDMARCRR form.dmarc
|
|
in ado
|
|
name <- parse DomainParser.sub_eof form.name VEName
|
|
ttl <- is_between min_ttl max_ttl form.ttl VETTL
|
|
pct <- is_between 0 100 (fromMaybe 100 dmarc.pct) VEDMARCpct
|
|
ri <- is_between 0 1000000 (fromMaybe 86400 dmarc.ri) VEDMARCri
|
|
-- No need to validate the target, actually, it will be completely discarded.
|
|
-- The different specific entries replace `target` completely.
|
|
in emptyRR { rrid = form.rrid, readonly = form.readonly, rrtype = "DMARC"
|
|
, name = name, ttl = ttl, target = "" -- `target` is discarded!
|
|
, dmarc = Just $ dmarc { pct = Just pct, ri = Just ri } }
|
|
|
|
validation :: ResourceRecord -> Either (Array Error) ResourceRecord
|
|
validation entry = case entry.rrtype of
|
|
"A" -> toEither $ validationA entry
|
|
"AAAA" -> toEither $ validationAAAA entry
|
|
"TXT" -> toEither $ validationTXT entry
|
|
"CNAME" -> toEither $ validationCNAME entry
|
|
"NS" -> toEither $ validationNS entry
|
|
"MX" -> toEither $ validationMX entry
|
|
"SRV" -> toEither $ validationSRV entry
|
|
"SPF" -> toEither $ validationSPF entry
|
|
"DKIM" -> toEither $ validationDKIM entry
|
|
"DMARC" -> toEither $ validationDMARC entry
|
|
_ -> toEither $ invalid [UNKNOWN]
|
|
|
|
id :: forall a. a -> a
|
|
id x = x
|