halogen-websocket-ipc-playzone/src/App/Validation/DNS.purs

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)
import Data.String.CodeUnits as CU
import Data.Validation.Semigroup (V, invalid, toEither)

import App.ResourceRecord (ResourceRecord, emptyRR, Mechanism, Modifier, Qualifier)
import App.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

-- | **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

  -- SPF
  | VESPFMechanismName (G.Error DomainParser.DomainError)
  | VESPFMechanismIPv4 (G.Error IPAddress.IPv4Error)
  | VESPFMechanismIPv6 (G.Error IPAddress.IPv6Error)

  | VESPFModifierName (G.Error DomainParser.DomainError)

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` allows 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 }

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 }

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 :: Mechanism -> V (Array Error) Mechanism
validate_SPF_mechanism m = case m.t of
  RR.A -> ado
    name <- parse (or_nothing DomainParser.sub_eof) m.v VESPFMechanismName
    in first m name -- name is discarded
  RR.MX -> ado
    name <- parse (or_nothing DomainParser.sub_eof) m.v VESPFMechanismName
    in first m name -- name is discarded
  RR.IP4 -> ado
    name <- parse (IPAddress.ipv4_range <|> IPAddress.ipv4) m.v VESPFMechanismIPv4
    in first m name -- name is discarded
  RR.IP6 -> ado
    name <- parse (IPAddress.ipv6_range <|> IPAddress.ipv6) m.v VESPFMechanismIPv6
    in first m name -- name is discarded
  _ -> pure m

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 }

--validationDKIM :: ResourceRecord -> V (Array Error) ResourceRecord
--validationDKIM form = ado
--  name     <- parse DomainParser.sub_eof form.name     VEName
--  ttl      <- is_between min_ttl max_ttl form.ttl      VETTL
--  mechanisms <- verification_loop validate_DKIM_mechanism (maybe [] id form.mechanisms)
--  -- 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!
--             , v = form.v, mechanisms = Just mechanisms
--             , modifiers = form.modifiers, q = form.q }

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
  _       -> toEither $ invalid [UNKNOWN]

id :: forall a. a -> a
id x = x