{-# LANGUAGE OverloadedStrings #-}

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
  String
tok <- App String
HasCallStack => App String
getTechnitiumApiKey
  HasCallStack => String -> String -> App ()
String -> String -> App ()
setTechnitiumReverseProxyACL String
tok String
"0.0.0.0/0"
  HasCallStack => String -> String -> App ()
String -> String -> App ()
registerTechnitiumZone String
tok String
"example.com"
  HasCallStack =>
String -> String -> String -> String -> String -> App ()
String -> String -> String -> String -> String -> App ()
registerTechnitiumRecord String
tok String
"example.com" String
"example.com" String
"TXT" String
"we own this domain and we're the good guys, trust us!"

  String
dohUrl <- App String
technitiumDohUrl
  let question :: RequestBody
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
  Request
req <- String -> App Request
externalRequest String
dohUrl App Request -> (Request -> Request) -> App Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> RequestBody -> String -> Request -> Request
addBody RequestBody
question String
"application/dns-message" (Request -> Request) -> (Request -> Request) -> Request -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Request -> Request
addHeader String
"Accept" String
"application/dns-message"
  App Response -> (Response -> App ()) -> App ()
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (String -> Request -> App Response
submit String
"POST" Request
req) ((Response -> App ()) -> App ()) -> (Response -> App ()) -> App ()
forall a b. (a -> b) -> a -> b
$ \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
env <- App Env
forall r (m :: * -> *). MonadReader r m => m r
ask
  String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> App String) -> String -> App String
forall a b. (a -> b) -> a -> b
$ String
"http://" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Env
env.dnsMockServerConfig.host String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word16 -> String
forall a. Show a => a -> String
show Env
env.dnsMockServerConfig.dohPort String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/dns-query"

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

getTechnitiumApiKey :: (HasCallStack) => App String
getTechnitiumApiKey :: HasCallStack => App String
getTechnitiumApiKey = do
  String
tok <- App String
HasCallStack => App String
requestTechnitiumApiKey
  HasCallStack => String -> String -> App ()
String -> String -> App ()
setTechnitiumReverseProxyACL String
tok String
"0.0.0.0/0"
  String -> App String
forall a. a -> App a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
tok

requestTechnitiumApiKey :: (HasCallStack) => App String
requestTechnitiumApiKey :: HasCallStack => App String
requestTechnitiumApiKey = do
  String
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")
  Request
req <- String -> App Request
externalRequest String
url App Request -> (Request -> Request) -> App Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [(String, String)] -> Request -> Request
addQueryParams [(String
"user", String
"admin"), (String
"pass", String
"admin"), (String
"tokenName", String
"someToken")]
  App Response -> (Response -> App String) -> App String
forall a.
HasCallStack =>
App Response -> (Response -> App a) -> App a
bindResponse (String -> Request -> App Response
submit String
"POST" Request
req) ((Response -> App String) -> App String)
-> (Response -> App String) -> App String
forall a b. (a -> b) -> a -> b
$ \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
  String
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")
  Request
req <- String -> App Request
externalRequest String
url App Request -> (Request -> Request) -> App Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [(String, String)] -> Request -> Request
addQueryParams [(String
"token", String
tok), (String
"reverseProxyNetworkACL", String
acl)]
  String -> Request -> App Response
submit String
"POST" Request
req App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200

registerTechnitiumZone :: (HasCallStack) => String -> String -> App ()
registerTechnitiumZone :: HasCallStack => String -> String -> App ()
registerTechnitiumZone String
tok String
zone = do
  String
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")
  Request
req <- String -> App Request
externalRequest String
url App Request -> (Request -> Request) -> App Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [(String, String)] -> Request -> Request
addQueryParams [(String
"token", String
tok), (String
"zone", String
zone), (String
"type", String
"primary")]
  String -> Request -> App Response
submit String
"POST" Request
req App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
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
  String
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, String)]
params =
        [ (String
"token", String
tok),
          (String
"zone", String
zone),
          (String
"domain", String
domain),
          (String
"type", String
typ),
          (String
"text", String
text)
        ]
  Request
req <- String -> App Request
externalRequest String
url App Request -> (Request -> Request) -> App Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [(String, String)] -> Request -> Request
addQueryParams [(String, String)]
params
  String -> Request -> App Response
submit String
"POST" Request
req App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
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
  String
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, String)]
params =
        [ (String
"token", String
tok),
          (String
"zone", String
zone),
          (String
"domain", String
domain),
          (String
"type", String
typ),
          (String
"text", String
text)
        ]
  Request
req <- String -> App Request
externalRequest String
url App Request -> (Request -> Request) -> App Request
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> [(String, String)] -> Request -> Request
addQueryParams [(String, String)]
params
  String -> Request -> App Response
submit String
"POST" Request
req App Response -> (Response -> App ()) -> App ()
forall a b. App a -> (a -> App b) -> App b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => Int -> Response -> App ()
Int -> Response -> App ()
assertStatus Int
200