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

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

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

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