Translate DNS mock test to integration testsuite

integration/integration.cabal

@@ -119,6 +119,7 @@ library
     Test.Connection
     Test.Conversation
     Test.Demo
+    Test.DNSMock
     Test.DomainVerification
     Test.EJPD
     Test.EnterpriseLogin
@@ -230,6 +231,7 @@ library
     , data-timeout
     , deriving-aeson
     , directory
+    , dns
     , errors
     , exceptions
     , extended

integration/test/Test/DNSMock.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Test.DNSMock where
+
+import Control.Lens
+import Control.Monad.Reader.Class
+import qualified Data.ByteString.Lazy as LBS
+import Data.String.Conversions (cs)
+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 test date (a TXT record) in Technitium
+-- (dns-server for tests)
+testNewTXTRecord :: (HasCallStack) => App ()
+testNewTXTRecord = do
+  env <- ask
+  let dohUrl = "http://localhost:80/dns-query"
+      apiUrl = "http://" <> env.dnsMockServerConfig.host <> ":" <> show env.dnsMockServerConfig.apiPort
+
+  -- api stuff
+  do
+    -- get api key
+    tok :: String <- do
+      let url = apiUrl <> "/user/createToken"
+      req <- externalRequest url <&> addQueryParams [("user", "admin"), ("pass", "admin"), ("tokenName", "someToken")]
+      bindResponse (submit "POST" req) $ \resp -> do
+        resp.status `shouldMatchInt` 200
+        resp.jsonBody %. "status" `shouldMatch` ("ok" :: String)
+        asString $ resp.jsonBody %. "token"
+
+    -- add 0.0.0.0/0 to ACL ()
+    do
+      let url = apiUrl <> "/settings/set"
+      req <- externalRequest url <&> addQueryParams [("token", tok), ("reverseProxyNetworkACL", "0.0.0.0/0")]
+      submit "POST" req >>= assertStatus 200
+
+    -- register zone
+    do
+      let url = apiUrl <> "/zones/create"
+      req <- externalRequest url <&> addQueryParams [("token", tok), ("zone", "example.com"), ("type", "primary")]
+      submit "POST" req >>= assertStatus 200
+
+    -- register txt record in zone
+    do
+      let url = apiUrl <> "/zones/records/add"
+          params =
+            [ ("token", tok),
+              ("zone", "example.com"),
+              ("domain", "example.com"),
+              ("type", "TXT"),
+              ("text", "hallo, welt!")
+            ]
+      req <- externalRequest url <&> addQueryParams params
+      submit "POST" req >>= assertStatus 200
+
+  -- ask the dns question and check response
+  do
+    let question = HTTP.RequestBodyBS $ encodeQuestion 0 (Question "example.com" TXT) mempty
+        headers =
+          [ ("Content-Type", "application/dns-message"),
+            ("Accept", "application/dns-message")
+          ]
+    req <- externalRequest dohUrl <&> addBody question "application/dns-message" . addHeaders headers
+    bindResponse (submit "POST" req) $ \resp -> do
+      let received = Dec.decode (resp.body :: ByteString)
+          expected = Right (DNSMessage {header = DNSHeader {identifier = 0, flags = DNSFlags {qOrR = QR_Response, opcode = OP_STD, authAnswer = True, trunCation = False, recDesired = True, recAvailable = True, rcode = NoErr, authenData = False, chkDisable = False}}, ednsHeader = EDNSheader (EDNS {ednsVersion = 0, ednsUdpSize = 1232, ednsDnssecOk = False, ednsOptions = []}), question = [Question {qname = "example.com.", qtype = TXT}], answer = [ResourceRecord {rrname = "example.com.", rrtype = TXT, rrclass = 1, rrttl = 3600, rdata = RD_TXT "hallo, welt!"}], authority = [], additional = []})
+      assertBool "Expected DNS response does match" (received == expected)

integration/test/Testlib/Env.hs

@@ -112,7 +112,8 @@ mkGlobalEnv cfgFile = do
         gRabbitMQConfigV0 = intConfig.rabbitmqV0,
         gRabbitMQConfigV1 = intConfig.rabbitmqV1,
         gTempDir = tempDir,
-        gTimeOutSeconds = timeOutSeconds
+        gTimeOutSeconds = timeOutSeconds,
+        gDNSMockServerConfig = intConfig.dnsMockServer
       }
   where
     createSSLContext :: Maybe FilePath -> IO (Maybe OpenSSL.SSLContext)
@@ -162,7 +163,8 @@ mkEnv currentTestName ge = do
           resourcePool = ge.gBackendResourcePool,
           rabbitMQConfig = ge.gRabbitMQConfig,
           timeOutSeconds = ge.gTimeOutSeconds,
-          currentTestName
+          currentTestName,
+          dnsMockServerConfig = ge.gDNSMockServerConfig
         }
 
 allCiphersuites :: [Ciphersuite]

integration/test/Testlib/HTTP.hs

@@ -86,6 +86,10 @@ addHeader :: String -> String -> HTTP.Request -> HTTP.Request
 addHeader name value req =
   req {HTTP.requestHeaders = (CI.mk . C8.pack $ name, C8.pack value) : HTTP.requestHeaders req}
 
+addHeaders :: [(String, String)] -> HTTP.Request -> HTTP.Request
+addHeaders [] = id
+addHeaders ((key, value) : hs) = addHeaders hs . addHeader key value
+
 setCookie :: String -> HTTP.Request -> HTTP.Request
 setCookie c r =
   addHeader "Cookie" (cs c) r
@@ -165,6 +169,10 @@ rawBaseRequest domain service versioned path = do
     let HostPort h p = serviceHostPort serviceMap service
      in "http://" <> h <> ":" <> show p <> ("/" <> joinHttpPath (pathSegsPrefix <> splitHttpPath path))
 
+-- | The bare minimum to ge a `HTTP.Request` given a URL
+externalRequest :: String -> App HTTP.Request
+externalRequest = liftIO . HTTP.parseRequest
+
 getAPIVersionFor :: (MakesValue domain) => domain -> App Int
 getAPIVersionFor domain = do
   d <- asString domain

integration/test/Testlib/Types.hs

@@ -105,6 +105,15 @@ instance FromJSON RabbitMQConfig where
         <*> ob .: fromString "tls"
         <*> ob .: fromString "vHost"
 
+data DNSMockServerConfig = DNSMockServerConfig
+  { host :: !String,
+    apiPort :: !Word16,
+    dohPort :: !Word16
+  }
+  deriving (Show, Generic)
+
+instance FromJSON DNSMockServerConfig
+
 -- | Initialised once per testsuite.
 data GlobalEnv = GlobalEnv
   { gServiceMap :: Map String ServiceMap,
@@ -122,7 +131,8 @@ data GlobalEnv = GlobalEnv
     gRabbitMQConfigV0 :: RabbitMQConfig,
     gRabbitMQConfigV1 :: RabbitMQConfig,
     gTempDir :: FilePath,
-    gTimeOutSeconds :: Int
+    gTimeOutSeconds :: Int,
+    gDNSMockServerConfig :: DNSMockServerConfig
   }
 
 data IntegrationConfig = IntegrationConfig
@@ -135,7 +145,8 @@ data IntegrationConfig = IntegrationConfig
     rabbitmq :: RabbitMQConfig,
     rabbitmqV0 :: RabbitMQConfig,
     rabbitmqV1 :: RabbitMQConfig,
-    cassandra :: CassandraConfig
+    cassandra :: CassandraConfig,
+    dnsMockServer :: DNSMockServerConfig
   }
   deriving (Show, Generic)
 
@@ -153,6 +164,7 @@ instance FromJSON IntegrationConfig where
         <*> o .: fromString "rabbitmq-v0"
         <*> o .: fromString "rabbitmq-v1"
         <*> o .: fromString "cassandra"
+        <*> o .: fromString "dnsMockServerEndpoint"
 
 data ServiceMap = ServiceMap
   { brig :: HostPort,
@@ -229,7 +241,8 @@ data Env = Env
     resourcePool :: ResourcePool BackendResource,
     rabbitMQConfig :: RabbitMQConfig,
     timeOutSeconds :: Int,
-    currentTestName :: Maybe String
+    currentTestName :: Maybe String,
+    dnsMockServerConfig :: DNSMockServerConfig
   }
 
 data Response = Response

services/integration.yaml

@@ -183,6 +183,11 @@ cassandra:
   host: 127.0.0.1
   port: 9042
 
+dnsMockServer:
+  host: localhost
+  apiPort: 5380
+  dohPort: 5381
+
 federation-v0:
   originDomain: federation-v0.example.com
   brig: