module Hasura.RQL.DDL.Network
  ( checkForHostnameWithSuffixInAllowlistObject,
    dropHostFromAllowList,
    runAddHostToTLSAllowlist,
    runDropHostFromTLSAllowlist,
  )
where

import Data.Text (pack)
import Data.Text.Extended
import Hasura.Base.Error
import Hasura.EncJSON
import Hasura.Metadata.Class ()
import Hasura.Prelude
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Metadata
import Hasura.RQL.Types.SchemaCache.Build
import Network.Types.Extended

runAddHostToTLSAllowlist ::
  (QErrM m, CacheRWM m, MetadataM m) =>
  TlsAllow ->
  m EncJSON
runAddHostToTLSAllowlist :: forall (m :: * -> *).
(QErrM m, CacheRWM m, MetadataM m) =>
TlsAllow -> m EncJSON
runAddHostToTLSAllowlist tlsAllowListEntry :: TlsAllow
tlsAllowListEntry@TlsAllow {String
Maybe String
Maybe [TlsPermission]
taHost :: String
taSuffix :: Maybe String
taPermit :: Maybe [TlsPermission]
taHost :: TlsAllow -> String
taSuffix :: TlsAllow -> Maybe String
taPermit :: TlsAllow -> Maybe [TlsPermission]
..} = do
  Network
networkMetadata <- Metadata -> Network
_metaNetwork (Metadata -> Network) -> m Metadata -> m Network
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Metadata
forall (m :: * -> *). MetadataM m => m Metadata
getMetadata

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
taHost) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
BadRequest (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"key \"host\" cannot be empty"

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Maybe String -> [TlsAllow] -> Bool
checkForHostWithSuffixInTLSAllowlist String
taHost Maybe String
taSuffix (Network -> [TlsAllow]
tlsList Network
networkMetadata)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    case Maybe String
taSuffix of
      Maybe String
Nothing ->
        Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
AlreadyExists
          (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"the host "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall t. ToTxt t => t -> Text
dquote (String -> Text
pack String
taHost)
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" already exists in the allowlist"
      Just String
suffix ->
        Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
AlreadyExists
          (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"the host "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall t. ToTxt t => t -> Text
dquote (String -> Text
pack String
taHost)
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with suffix "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall t. ToTxt t => t -> Text
dquote (String -> Text
pack String
suffix)
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" already exists in the allowlist"

  m () -> m ()
forall (m :: * -> *) a. (QErrM m, CacheRM m) => m a -> m a
withNewInconsistentObjsCheck
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ MetadataModifier -> m ()
forall (m :: * -> *).
(MetadataM m, CacheRWM m) =>
MetadataModifier -> m ()
buildSchemaCache
    (MetadataModifier -> m ()) -> MetadataModifier -> m ()
forall a b. (a -> b) -> a -> b
$ TlsAllow -> MetadataModifier
addHostToTLSAllowList TlsAllow
tlsAllowListEntry

  EncJSON -> m EncJSON
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EncJSON
successMsg
  where
    tlsList :: Network -> [TlsAllow]
tlsList Network
nm = Network -> [TlsAllow]
networkTlsAllowlist Network
nm

runDropHostFromTLSAllowlist ::
  (QErrM m, CacheRWM m, MetadataM m) =>
  DropHostFromTLSAllowlist ->
  m EncJSON
runDropHostFromTLSAllowlist :: forall (m :: * -> *).
(QErrM m, CacheRWM m, MetadataM m) =>
DropHostFromTLSAllowlist -> m EncJSON
runDropHostFromTLSAllowlist (DropHostFromTLSAllowlist String
hostname Maybe String
maybeSuffix) = do
  Network
networkMetadata <- Metadata -> Network
_metaNetwork (Metadata -> Network) -> m Metadata -> m Network
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Metadata
forall (m :: * -> *). MetadataM m => m Metadata
getMetadata

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
hostname) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
BadRequest (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"hostname cannot be empty"

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Maybe String -> [TlsAllow] -> Bool
checkForHostWithSuffixInTLSAllowlist String
hostname Maybe String
maybeSuffix (Network -> [TlsAllow]
networkTlsAllowlist Network
networkMetadata)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    case Maybe String
maybeSuffix of
      Maybe String
Nothing ->
        Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
NotExists
          (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"the host "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall t. ToTxt t => t -> Text
dquote (String -> Text
pack String
hostname)
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" isn't present in the allowlist"
      Just String
suffix ->
        Code -> Text -> m ()
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
NotExists
          (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"the host "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall t. ToTxt t => t -> Text
dquote (String -> Text
pack String
hostname)
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with suffix "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall t. ToTxt t => t -> Text
dquote (String -> Text
pack String
suffix)
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" isn't present in the allowlist"

  m () -> m ()
forall (m :: * -> *) a. (QErrM m, CacheRM m) => m a -> m a
withNewInconsistentObjsCheck
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ MetadataModifier -> m ()
forall (m :: * -> *).
(MetadataM m, CacheRWM m) =>
MetadataModifier -> m ()
buildSchemaCache
    (MetadataModifier -> m ()) -> MetadataModifier -> m ()
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> MetadataModifier
dropHostFromAllowList String
hostname Maybe String
maybeSuffix

  EncJSON -> m EncJSON
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure EncJSON
successMsg

addHostToTLSAllowList :: TlsAllow -> MetadataModifier
addHostToTLSAllowList :: TlsAllow -> MetadataModifier
addHostToTLSAllowList TlsAllow
tlsaObj = (Metadata -> Metadata) -> MetadataModifier
MetadataModifier ((Metadata -> Metadata) -> MetadataModifier)
-> (Metadata -> Metadata) -> MetadataModifier
forall a b. (a -> b) -> a -> b
$ \Metadata
m ->
  Metadata
m {_metaNetwork :: Network
_metaNetwork = [TlsAllow] -> Network
Network ([TlsAllow] -> Network) -> [TlsAllow] -> Network
forall a b. (a -> b) -> a -> b
$ (Metadata -> [TlsAllow]
tlsList Metadata
m) [TlsAllow] -> [TlsAllow] -> [TlsAllow]
forall a. [a] -> [a] -> [a]
++ [TlsAllow
tlsaObj]}
  where
    tlsList :: Metadata -> [TlsAllow]
tlsList Metadata
md = Network -> [TlsAllow]
networkTlsAllowlist (Metadata -> Network
_metaNetwork Metadata
md)

dropHostFromAllowList :: String -> Maybe String -> MetadataModifier
dropHostFromAllowList :: String -> Maybe String -> MetadataModifier
dropHostFromAllowList String
host Maybe String
maybeSuffix = (Metadata -> Metadata) -> MetadataModifier
MetadataModifier ((Metadata -> Metadata) -> MetadataModifier)
-> (Metadata -> Metadata) -> MetadataModifier
forall a b. (a -> b) -> a -> b
$ \Metadata
m ->
  Metadata
m {_metaNetwork :: Network
_metaNetwork = [TlsAllow] -> Network
Network ([TlsAllow] -> Network) -> [TlsAllow] -> Network
forall a b. (a -> b) -> a -> b
$ Metadata -> [TlsAllow]
filteredList Metadata
m}
  where
    tlsList :: Metadata -> [TlsAllow]
tlsList Metadata
md = Network -> [TlsAllow]
networkTlsAllowlist (Metadata -> Network
_metaNetwork Metadata
md)

    filteredList :: Metadata -> [TlsAllow]
filteredList Metadata
md = (TlsAllow -> Bool) -> [TlsAllow] -> [TlsAllow]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (TlsAllow -> Bool) -> TlsAllow -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> TlsAllow -> Bool
checkForHostnameWithSuffixInAllowlistObject String
host Maybe String
maybeSuffix) (Metadata -> [TlsAllow]
tlsList Metadata
md)

checkForHostnameWithSuffixInAllowlistObject :: String -> Maybe String -> TlsAllow -> Bool
checkForHostnameWithSuffixInAllowlistObject :: String -> Maybe String -> TlsAllow -> Bool
checkForHostnameWithSuffixInAllowlistObject String
host Maybe String
maybeSuffix TlsAllow
tlsa = String
host String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (TlsAllow -> String
taHost TlsAllow
tlsa) Bool -> Bool -> Bool
&& Maybe String
maybeSuffix Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== (TlsAllow -> Maybe String
taSuffix TlsAllow
tlsa)

checkForHostWithSuffixInTLSAllowlist :: String -> Maybe String -> [TlsAllow] -> Bool
checkForHostWithSuffixInTLSAllowlist :: String -> Maybe String -> [TlsAllow] -> Bool
checkForHostWithSuffixInTLSAllowlist String
host Maybe String
maybeSuffix [TlsAllow]
tlsAllowList =
  (TlsAllow -> Bool) -> [TlsAllow] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> Maybe String -> TlsAllow -> Bool
checkForHostnameWithSuffixInAllowlistObject String
host Maybe String
maybeSuffix) [TlsAllow]
tlsAllowList