{-# LANGUAGE OverloadedStrings #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2025 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 Test.DNSMock where

import Control.Lens
import Control.Monad.Reader.Class
import qualified Data.ByteString.Lazy as LBS
import Network.DNS
import Network.DNS.Decode as Dec
import qualified Network.HTTP.Client as HTTP
import Testlib.Prelude

type LByteString = LBS.ByteString

-- | Test that we can provide and lookup a TXT record in
-- Technitium (dns-server for tests)
testNewTXTRecord :: (HasCallStack) => App ()
testNewTXTRecord :: HasCallStack => App ()
testNewTXTRecord = do
  tok <- App String
HasCallStack => App String
getTechnitiumApiKey
  setTechnitiumReverseProxyACL tok "0.0.0.0/0"
  registerTechnitiumZone tok "example.com"
  registerTechnitiumRecord tok "example.com" "example.com" "TXT" "we own this domain and we're the good guys, trust us!"

  dohUrl <- technitiumDohUrl
  let question = ByteString -> RequestBody
HTTP.RequestBodyBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ Word16 -> Question -> QueryControls -> ByteString
encodeQuestion Word16
0 (ByteString -> TYPE -> Question
Question ByteString
"example.com" TYPE
TXT) QueryControls
forall a. Monoid a => a
mempty
  req <- externalRequest dohUrl <&> addBody question "application/dns-message" . addHeader "Accept" "application/dns-message"
  bindResponse (submit "POST" req) $ \Response
resp -> do
    let Either DNSError DNSMessage
received :: Either DNSError DNSMessage = ByteString -> Either DNSError DNSMessage
Dec.decode (Response
resp.body :: ByteString)
        Either DNSError DNSMessage
expected :: Either DNSError DNSMessage = DNSMessage -> Either DNSError DNSMessage
forall a b. b -> Either a b
Right (DNSMessage {header :: DNSHeader
header = DNSHeader {identifier :: Word16
identifier = Word16
0, flags :: DNSFlags
flags = DNSFlags {qOrR :: QorR
qOrR = QorR
QR_Response, opcode :: OPCODE
opcode = OPCODE
OP_STD, authAnswer :: Bool
authAnswer = Bool
True, trunCation :: Bool
trunCation = Bool
False, recDesired :: Bool
recDesired = Bool
True, recAvailable :: Bool
recAvailable = Bool
True, rcode :: RCODE
rcode = RCODE
NoErr, authenData :: Bool
authenData = Bool
False, chkDisable :: Bool
chkDisable = Bool
False}}, ednsHeader :: EDNSheader
ednsHeader = EDNS -> EDNSheader
EDNSheader (EDNS {ednsVersion :: Word8
ednsVersion = Word8
0, ednsUdpSize :: Word16
ednsUdpSize = Word16
1232, ednsDnssecOk :: Bool
ednsDnssecOk = Bool
False, ednsOptions :: [OData]
ednsOptions = []}), question :: [Question]
question = [Question {qname :: ByteString
qname = ByteString
"example.com.", qtype :: TYPE
qtype = TYPE
TXT}], answer :: Answers
answer = [ResourceRecord {rrname :: ByteString
rrname = ByteString
"example.com.", rrtype :: TYPE
rrtype = TYPE
TXT, rrclass :: Word16
rrclass = Word16
1, rrttl :: TTL
rrttl = TTL
3600, rdata :: RData
rdata = ByteString -> RData
RD_TXT ByteString
"we own this domain and we're the good guys, trust us!"}], authority :: Answers
authority = [], additional :: Answers
additional = []})
    -- if we had aeson instances for DNSError and DNSMessage, we could get nicer error messages here, but meh.
    Either DNSError DNSMessage -> String
forall a. Show a => a -> String
show Either DNSError DNSMessage
received String -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` Either DNSError DNSMessage -> String
forall a. Show a => a -> String
show Either DNSError DNSMessage
expected

technitiumDohUrl :: App String
technitiumDohUrl :: App String
technitiumDohUrl = do
  env <- App Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  pure $ "http://" <> env.dnsMockServerConfig.host <> ":" <> show env.dnsMockServerConfig.dohPort <> "/dns-query"

technitiumApiUrl :: App String
technitiumApiUrl :: App String
technitiumApiUrl = do
  env <- App Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  pure $ "http://" <> env.dnsMockServerConfig.host <> ":" <> show env.dnsMockServerConfig.apiPort <> "/api"

getTechnitiumApiKey :: (HasCallStack) => App String
getTechnitiumApiKey :: HasCallStack => App String
getTechnitiumApiKey = do
  tok <- App String
HasCallStack => App String
requestTechnitiumApiKey
  setTechnitiumReverseProxyACL tok "0.0.0.0/0"
  pure tok

requestTechnitiumApiKey :: (HasCallStack) => App String
requestTechnitiumApiKey :: HasCallStack => App String
requestTechnitiumApiKey = do
  url <- App String
technitiumApiUrl App String -> (String -> String) -> App String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/user/createToken")
  req <- externalRequest url <&> addQueryParams [("user", "admin"), ("pass", "admin"), ("tokenName", "someToken")]
  bindResponse (submit "POST" req) $ \Response
resp -> do
    Response
resp.status Int -> Int -> App ()
forall a. (MakesValue a, HasCallStack) => a -> Int -> App ()
`shouldMatchInt` Int
200
    Response
resp.jsonBody Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"status" App Value -> String -> App ()
forall a b.
(MakesValue a, MakesValue b, HasCallStack) =>
a -> b -> App ()
`shouldMatch` (String
"ok" :: String)
    App Value -> App String
forall a. (HasCallStack, MakesValue a) => a -> App String
asString (App Value -> App String) -> App Value -> App String
forall a b. (a -> b) -> a -> b
$ Response
resp.jsonBody Maybe Value -> String -> App Value
forall a. (HasCallStack, MakesValue a) => a -> String -> App Value
%. String
"token"

setTechnitiumReverseProxyACL :: (HasCallStack) => String -> String -> App ()
setTechnitiumReverseProxyACL :: HasCallStack => String -> String -> App ()
setTechnitiumReverseProxyACL String
tok String
acl = do
  url <- App String
technitiumApiUrl App String -> (String -> String) -> App String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/settings/set")
  req <- externalRequest url <&> addQueryParams [("token", tok), ("reverseProxyNetworkACL", acl)]
  submit "POST" req >>= assertStatus 200

registerTechnitiumZone :: (HasCallStack) => String -> String -> App ()
registerTechnitiumZone :: HasCallStack => String -> String -> App ()
registerTechnitiumZone String
tok String
zone = do
  url <- App String
technitiumApiUrl App String -> (String -> String) -> App String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/zones/create")
  req <- externalRequest url <&> addQueryParams [("token", tok), ("zone", zone), ("type", "primary")]
  submit "POST" req >>= assertStatus 200

registerTechnitiumRecord :: (HasCallStack) => String -> String -> String -> String -> String -> App ()
registerTechnitiumRecord :: HasCallStack =>
String -> String -> String -> String -> String -> App ()
registerTechnitiumRecord String
tok String
zone String
domain String
typ String
text = do
  url <- App String
technitiumApiUrl App String -> (String -> String) -> App String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/zones/records/add")
  let params =
        [ (String
"token", String
tok),
          (String
"zone", String
zone),
          (String
"domain", String
domain),
          (String
"type", String
typ),
          (String
"text", String
text)
        ]
  req <- externalRequest url <&> addQueryParams params
  submit "POST" req >>= assertStatus 200

deleteTechnitiumRecord :: (HasCallStack) => String -> String -> String -> String -> String -> App ()
deleteTechnitiumRecord :: HasCallStack =>
String -> String -> String -> String -> String -> App ()
deleteTechnitiumRecord String
tok String
zone String
domain String
typ String
text = do
  url <- App String
technitiumApiUrl App String -> (String -> String) -> App String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/zones/records/delete")
  let params =
        [ (String
"token", String
tok),
          (String
"zone", String
zone),
          (String
"domain", String
domain),
          (String
"type", String
typ),
          (String
"text", String
text)
        ]
  req <- externalRequest url <&> addQueryParams params
  submit "POST" req >>= assertStatus 200