graphql-engine/server/src-lib/Hasura/Backends/BigQuery/Source.hs

{-# LANGUAGE DeriveAnyClass               #-}
{-# LANGUAGE NoGeneralisedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Hasura.Backends.BigQuery.Source where


import           Control.Concurrent.MVar
import           Control.DeepSeq
import qualified Crypto.PubKey.RSA.Types as Cry
import qualified Data.Aeson              as J
import qualified Data.Aeson.Casing       as J
import qualified Data.Aeson.TH           as J
import qualified Data.ByteString.Lazy    as BL
import qualified Data.HashMap.Strict     as HM
import           Data.Hashable           (hashWithSalt)
import qualified Data.Text               as T
import qualified Data.Text.Encoding      as TE
import qualified Data.X509               as X509
import qualified Data.X509.Memory        as X509
import           Hasura.Incremental      (Cacheable (..))
import           Hasura.Prelude
import           System.IO.Unsafe        (unsafePerformIO)


data PKey = PKey
  { unPKey     :: Cry.PrivateKey
  , originalBS :: Text
  }
  deriving (Show, Eq, Data, Generic, NFData, Hashable)
deriving instance Generic Cry.PrivateKey -- orphan
deriving instance Generic Cry.PublicKey -- orphan
deriving instance J.ToJSON Cry.PrivateKey -- orphan
deriving instance J.ToJSON Cry.PublicKey -- orphan
deriving instance Hashable Cry.PrivateKey -- orphan
deriving instance Hashable Cry.PublicKey -- orphan
instance Arbitrary Cry.PrivateKey where -- orphan
  arbitrary = genericArbitrary
instance Arbitrary Cry.PublicKey where -- orphan
  arbitrary = genericArbitrary
instance Arbitrary PKey where
  arbitrary = genericArbitrary
instance J.FromJSON PKey where
  parseJSON = J.withText "private_key" $ \k ->
    case X509.readKeyFileFromMemory $ TE.encodeUtf8 k of
      [X509.PrivKeyRSA k'] -> return $ PKey k' k
      _                    -> fail "unable to parse private key"
instance J.ToJSON PKey where
  toJSON PKey{..} = J.toJSON originalBS


newtype GoogleAccessToken
  = GoogleAccessToken Text
  deriving (Show, Eq, J.FromJSON, J.ToJSON, Hashable, Generic, Data, NFData)
instance Arbitrary GoogleAccessToken where
  arbitrary = genericArbitrary


data TokenResp
  = TokenResp
  { _trAccessToken :: !GoogleAccessToken
  , _trExpiresAt   :: !Integer -- Number of seconds until expiry from `now`, but we add `now` seconds to this for easy tracking
  } deriving (Eq, Show, Data, NFData, Generic, Hashable)
instance J.FromJSON TokenResp where
  parseJSON = J.withObject "TokenResp" $ \o -> TokenResp
    <$> o J..: "access_token"
    <*> o J..: "expires_in"
instance Arbitrary TokenResp where
  arbitrary = genericArbitrary


dummyTokenResp :: TokenResp
dummyTokenResp = TokenResp (GoogleAccessToken "DUMMY") 0


data ServiceAccount
  = ServiceAccount
  { _saClientEmail :: !Text
  , _saPrivateKey  :: !PKey
  , _saProjectId   :: !Text
  } deriving (Eq, Show, Data, NFData, Generic, Hashable)
$(J.deriveJSON (J.aesonDrop 3 J.snakeCase){J.omitNothingFields=False} ''ServiceAccount)
instance Arbitrary ServiceAccount where
  arbitrary = genericArbitrary


data ConfigurationJSON a
  = FromEnvJSON Text
  | FromYamlJSON a
  deriving stock (Show, Eq, Generic)
  deriving (NFData, Hashable)
instance Arbitrary a => Arbitrary (ConfigurationJSON a) where
  arbitrary = genericArbitrary
instance J.FromJSON a => J.FromJSON (ConfigurationJSON a) where
  parseJSON = \case
    J.Object o | Just (J.String text) <- HM.lookup "from_env" o -> pure (FromEnvJSON text)
    J.String s -> case J.eitherDecode . BL.fromStrict . TE.encodeUtf8 $ s of
      Left {}  -> fail "error parsing configuration json"
      Right sa -> pure sa
    j -> fmap FromYamlJSON (J.parseJSON j)
instance J.ToJSON a => J.ToJSON (ConfigurationJSON a) where
  toJSON = \case
    FromEnvJSON i  -> J.object ["from_env" J..= i]
    FromYamlJSON j -> J.toJSON j


-- | Configuration inputs when they are a YAML array or an Env var whos value is
-- a comma-separated string
data ConfigurationInputs
  = FromYamls ![Text]
  | FromEnvs !Text
  deriving stock (Show, Eq, Generic)
  deriving (NFData, Hashable)
instance Arbitrary ConfigurationInputs where
  arbitrary = genericArbitrary
instance J.ToJSON ConfigurationInputs where
  toJSON = \case
    FromYamls i -> J.toJSON i
    FromEnvs i  -> J.object ["from_env" J..= i]
instance J.FromJSON ConfigurationInputs where
  parseJSON = \case
    J.Object o    -> FromEnvs <$> o J..: "from_env"
    s@(J.Array _) -> FromYamls <$> J.parseJSON s
    _             -> fail "one of array or object must be provided"


-- | Configuration input when the YAML value as well as the Env var have
-- singlular values
data ConfigurationInput
  = FromYaml !Text
  | FromEnv !Text
  deriving stock (Show, Eq, Generic)
  deriving (NFData, Hashable)
instance Arbitrary ConfigurationInput where
  arbitrary = genericArbitrary
instance J.ToJSON ConfigurationInput where
  toJSON = \case
    FromYaml i -> J.toJSON i
    FromEnv i  -> J.object ["from_env" J..= i]
instance J.FromJSON ConfigurationInput where
  parseJSON = \case
    J.Object o     -> FromEnv <$> o J..: "from_env"
    s@(J.String _) -> FromYaml <$> J.parseJSON s
    (J.Number n)   -> FromYaml <$> J.parseJSON (J.String (T.pack (show n)))
    _              -> fail "one of string or number or object must be provided"


data BigQueryConnSourceConfig
  = BigQueryConnSourceConfig
  { _cscServiceAccount    :: !(ConfigurationJSON ServiceAccount)
  , _cscDatasets          :: !ConfigurationInputs
  , _cscProjectId         :: !ConfigurationInput -- this is part of service-account.json, but we put it here on purpose
  , _cscGlobalSelectLimit :: !(Maybe ConfigurationInput)
  } deriving (Eq, Generic, NFData)
$(J.deriveJSON (J.aesonDrop 4 J.snakeCase){J.omitNothingFields=True} ''BigQueryConnSourceConfig)
deriving instance Show BigQueryConnSourceConfig
deriving instance Hashable BigQueryConnSourceConfig
instance Arbitrary BigQueryConnSourceConfig where
  arbitrary = genericArbitrary
instance Cacheable BigQueryConnSourceConfig where
  unchanged _ = (==)


data BigQuerySourceConfig
  = BigQuerySourceConfig
  { _scServiceAccount    :: !ServiceAccount
  , _scDatasets          :: ![Text]
  , _scProjectId         :: !Text -- this is part of service-account.json, but we put it here on purpose
  , _scAccessTokenMVar   :: !(MVar (Maybe TokenResp))
  , _scGlobalSelectLimit :: !Int
  } deriving (Eq, Generic, NFData)
$(J.deriveJSON (J.aesonDrop 3 J.snakeCase){J.omitNothingFields=True} ''BigQuerySourceConfig)
deriving instance Show BigQuerySourceConfig
deriving instance Hashable BigQuerySourceConfig
instance Arbitrary BigQuerySourceConfig where
  arbitrary = genericArbitrary
instance Cacheable BigQuerySourceConfig where
  unchanged _ = (==)

instance Show (MVar (Maybe TokenResp)) where
  -- show = maybe "NOTHING" (const "_REDACTED_") . unsafePerformIO . readIORef
  show = (const "_REDACTED_")
instance J.FromJSON (MVar (Maybe TokenResp)) where
  parseJSON _ = pure $ unsafePerformIO $ newEmptyMVar
instance J.ToJSON (MVar (Maybe TokenResp)) where
  toJSON _ = J.String "_REDACTED_"
instance Hashable (MVar (Maybe TokenResp)) where
  hashWithSalt i r = hashWithSalt i (unsafePerformIO $ readMVar r)
instance Arbitrary (MVar (Maybe TokenResp)) where
  arbitrary = genericArbitrary @(Maybe TokenResp) <&> (unsafePerformIO . newMVar)