{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Data.Domain where

import Cassandra
import Control.Lens ((?~))
import Data.Aeson (FromJSON, FromJSONKey, FromJSONKeyFunction (FromJSONKeyTextParser), ToJSON, ToJSONKey (toJSONKey))
import Data.Aeson qualified as Aeson
import Data.Aeson.Types (toJSONKeyText)
import Data.Attoparsec.ByteString ((<?>))
import Data.Attoparsec.ByteString.Char8 qualified as Atto
import Data.Bifunctor (Bifunctor (first))
import Data.Binary
import Data.ByteString qualified as BS
import Data.ByteString.Builder qualified as Builder
import Data.ByteString.Char8 qualified as BS.Char8
import Data.ByteString.Conversion
import Data.Hashable
import Data.OpenApi qualified as S
import Data.Schema
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text.E
import Imports hiding (isAlphaNum)
import Servant (FromHttpApiData (..), ToHttpApiData (..))
import Test.QuickCheck (Arbitrary (arbitrary))
import Test.QuickCheck qualified as QC
import Util.Attoparsec (takeUpToWhile)

-- | A Fully Qualified Domain Name (FQDN).
--
-- Following [RFC-1035](https://www.ietf.org/rfc/rfc1035.txt), Section 2.3.1,
-- except for:
-- * not allowing a space @" "@
-- * accepting digits as first letter of labels (except for the last label, not allowing IPs)
-- * requiring at least two labels (except for "localhost")
-- * not only must labels be 63 chars or less, the whole domain must be 253 chars or less
--
-- <domain> ::= <label> "." <tld> | <label> "." <domain>
-- <tld> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
-- <label> ::= <let-dig> [ [ <ldh-str> ] <let-dig> ]
-- <ldh-str> ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>
-- <let-dig-hyp> ::= <let-dig> | "-"
-- <let-dig> ::= <letter> | <digit>
-- <letter> ::= any one of the 52 alphabetic characters A through Z in
-- upper case and a through z in lower case
-- <digit> ::= any one of the ten digits 0 through 9
--
-- The domain will be normalized to lowercase when parsed.
newtype Domain = Domain {_domainText :: Text}
  deriving stock (Eq, Ord, Generic, Show)
  deriving newtype (S.ToParamSchema, Binary)
  deriving (FromJSON, ToJSON, S.ToSchema) via Schema Domain
  deriving (Hashable)

instance ToSchema Domain where
  schema =
    domainText .= parsedText "Domain" mkDomain
      & doc . S.schema . S.example ?~ "example.com"

domainText :: Domain -> Text
domainText = _domainText

mkDomain :: Text -> Either String Domain
mkDomain = Atto.parseOnly (domainParser <* Atto.endOfInput) . Text.E.encodeUtf8

mkDomainFromBS :: ByteString -> Either String Domain
mkDomainFromBS = runParser parser

instance FromByteString Domain where
  parser = domainParser

instance ToByteString Domain where
  builder = Builder.lazyByteString . BS.Char8.fromStrict . Text.E.encodeUtf8 . _domainText

instance FromHttpApiData Domain where
  parseUrlPiece = first Text.pack . mkDomain

instance ToHttpApiData Domain where
  toUrlPiece = toUrlPiece . _domainText

domainParser :: Atto.Parser Domain
domainParser = do
  parts <- domainLabel `Atto.sepBy1` Atto.char '.'
  let isLocalhost = case parts of
        [p] -> BS.Char8.map toLower p == "localhost"
        _ -> False
  when (length parts < 2 && not isLocalhost) $
    fail "Invalid domain name: cannot be dotless domain"
  when (isDigit (BS.Char8.head (last parts))) $
    fail "Invalid domain name: last label cannot start with digit"
  let bs = BS.intercalate "." parts
  when (BS.length bs > 253) $
    fail "Invalid domain name: too long"
  case Text.E.decodeUtf8' bs of
    Left err -> fail $ "Invalid UTF-8 in Domain: " <> show err
    Right txt -> pure . Domain $ Text.toCaseFold txt
  where
    domainLabel :: Atto.Parser ByteString
    domainLabel = do
      match <- BS.Char8.cons <$> alphaNum <*> takeUpToWhile 62 isAlphaNumHyphen
      when (BS.Char8.last match == '-') $
        fail "Invalid domain label: last character is a hyphen"
      pure match
    alphaNum = Atto.satisfy isAlphaNum <?> "alphanumeric character"
    isAlphaNum = Atto.inClass "A-Za-z0-9"
    isAlphaNumHyphen = Atto.inClass "A-Za-z0-9-"

instance ToJSONKey Domain where
  toJSONKey = toJSONKeyText domainText

instance FromJSONKey Domain where
  fromJSONKey = FromJSONKeyTextParser $ either fail pure . mkDomain

instance Arbitrary Domain where
  arbitrary =
    either (error . ("arbitrary @Domain: " <>)) id . mkDomain . getDomainText <$> arbitrary

instance QC.CoArbitrary Domain where
  coarbitrary d = QC.coarbitrary (Text.unpack (domainText d))

-- | only for QuickCheck
newtype DomainText = DomainText {getDomainText :: Text}
  deriving (Eq, Show)

instance Arbitrary DomainText where
  arbitrary = DomainText <$> domain
    where
      -- <domain> ::= <label> "." <tld> | <label> "." <domain>
      domain =
        QC.oneof
          [ conc [label, pure ".", tldLabel],
            conc [label, pure ".", domain]
          ]
          `QC.suchThat` ((<= 255) . Text.length)
      -- <tld> ::= <letter> [ [ <ldh-str> ] <let-dig> ]
      tldLabel =
        conc [letter, opt (conc [opt ldhStr, letDig])]
          `QC.suchThat` ((<= 63) . Text.length)
      -- <label> ::= <let-dig> [ [ <ldh-str> ] <let-dig> ]
      label =
        conc [letDig, opt (conc [opt ldhStr, letDig])]
          `QC.suchThat` ((<= 63) . Text.length)
      -- <ldh-str> ::= <let-dig-hyp> | <let-dig-hyp> <ldh-str>
      ldhStr =
        QC.frequency
          [ (1, letDigHyp),
            (3, conc [letDigHyp, ldhStr]) -- to get longer labels
          ]
          `QC.suchThat` ((<= 61) . Text.length)
      -- <let-dig-hyp> ::= <let-dig> | "-"
      letDigHyp =
        QC.frequency
          [ (1, pure "-"),
            (5, letDig) -- fewer hyphens
          ]
      -- <let-dig> ::= <letter> | <digit>
      letDig =
        QC.oneof [letter, digit]
      -- <letter> ::= any one of the 52 alphabetic characters A through Z in
      letter =
        Text.singleton <$> QC.elements (['a' .. 'z'] <> ['A' .. 'Z'])
      -- <digit> ::= any one of the ten digits 0 through 9
      digit =
        Text.singleton <$> QC.elements ['0' .. '9']
      -- upper case and a through z in lower case
      -- helpers
      conc :: [QC.Gen Text] -> QC.Gen Text
      conc = fmap Text.concat . sequenceA
      opt :: QC.Gen Text -> QC.Gen Text
      opt x =
        QC.frequency
          [ (1, pure ""),
            (5, x) -- to get longer labels
          ]

instance Cql Domain where
  ctype = Tagged TextColumn
  toCql = CqlText . domainText
  fromCql (CqlText txt) = mkDomain txt
  fromCql _ = Left "Domain: Text expected"
