Target.hs

-- | Explicit, validated configuration for one direct administrative target.
module ClickHouseMigrate.Target
  ( TargetKey,
    targetKey,
    targetKeyText,
    DirectEndpoint,
    directEndpoint,
    endpointText,
    ServerId,
    serverId,
    serverIdText,
    QueryId,
    queryId,
    queryIdText,
    LedgerId,
    ledgerId,
    newLedgerId,
    ledgerIdText,
    LedgerNamespace,
    ledgerNamespace,
    ledgerNamespaceText,
    LedgerBinding (FirstUse, ExistingLedger),
    Credentials,
    basicCredentials,
    HttpLimits,
    httpLimits,
    defaultHttpLimits,
    TargetConfig,
    targetConfig,
    TargetTopology (DirectServer, ReplicatedCluster),
    ClusterName,
    clusterName,
    clusterNameText,
    replicatedTargetConfig,
    configuredTopology,
    configuredTargetKey,
    configuredLedgerBinding,
    TargetError (..),
    ServerIdentity,
    identityServerId,
    identityVersion,
    identityHostName,
  )
where

import ClickHouseMigrate.Internal.Identity (freshUuid)
import ClickHouseMigrate.Internal.TargetTypes
import ClickHouseMigrate.Prelude
import Data.Char (isAsciiLower, isAsciiUpper)
import Data.List.NonEmpty qualified as NE
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Encoding
import Text.Read (readMaybe)

data TargetError = InvalidTargetKey | InvalidEndpoint | InvalidServerId | InvalidQueryId | InvalidLedgerId | InvalidLedgerNamespace | InvalidCredentials | InvalidHttpLimits | InvalidClusterName | DuplicateReplica
  deriving stock (Eq, Ord, Show)

targetKey :: Text -> Either TargetError TargetKey
targetKey value
  | valid 256 (\c -> lowerDigit c || c `elem` ("/_:.-" :: String)) value && maybe False (lowerDigit . fst) (Text.uncons value) = Right (TargetKey value)
  | otherwise = Left InvalidTargetKey

directEndpoint :: Text -> Either TargetError DirectEndpoint
directEndpoint value = do
  authority <- case Text.stripPrefix "http://" value of
    Just rest -> Right rest
    Nothing -> maybe (Left InvalidEndpoint) Right (Text.stripPrefix "https://" value)
  let hostPort = maybe authority id (Text.stripSuffix "/" authority)
      validHost c = isAsciiLower c || isAsciiUpper c || digit c || c `elem` (".-" :: String)
      validPort "" = True
      validPort suffix = case Text.stripPrefix ":" suffix of
        Just port | not (Text.null port) && Text.all digit port -> case readMaybe (Text.unpack port) :: Maybe Int of
          Just n -> n > 0 && n <= 65535
          _ -> False
        _ -> False
      validAuthority = case Text.stripPrefix "[" hostPort of
        Just ipv6 -> case Text.breakOn "]" ipv6 of
          (host, suffix) -> not (Text.null host) && Text.all (\c -> digit c || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F') || c `elem` (":." :: String)) host && maybe False validPort (Text.stripPrefix "]" suffix)
        Nothing -> let (host, port) = Text.breakOn ":" hostPort in not (Text.null host) && Text.all validHost host && validPort port
  if Text.length value <= 2048 && validAuthority then Right (DirectEndpoint value) else Left InvalidEndpoint

serverId :: Text -> Either TargetError ServerId
serverId value = if uuid value then Right (ServerId value) else Left InvalidServerId

queryId :: Text -> Either TargetError QueryId
queryId value = if valid 128 (\c -> lowerDigit c || isAsciiUpper c || c `elem` ("_-" :: String)) value then Right (QueryId value) else Left InvalidQueryId

ledgerId :: Text -> Either TargetError LedgerId
ledgerId value = if uuid value then Right (LedgerId value) else Left InvalidLedgerId

ledgerNamespace :: Text -> Either TargetError LedgerNamespace
ledgerNamespace value
  | valid 128 (\c -> lowerDigit c || c == '_') value && maybe False (\(c, _) -> isAsciiLower c || c == '_') (Text.uncons value) = Right (LedgerNamespace value)
  | otherwise = Left InvalidLedgerNamespace

basicCredentials :: Text -> Text -> Either TargetError Credentials
basicCredentials user password
  | Text.null user || Text.any (`elem` (":\r\n\0" :: String)) user || Text.any (== '\0') password = Left InvalidCredentials
  | otherwise = Right (Credentials (Encoding.encodeUtf8 user) (Encoding.encodeUtf8 password))

-- | Deadline and raw-byte bound. Ordinary responses are bounded in total;
-- complete ledger reads apply this byte bound per JSON row (excluding LF).
-- Decoded history and reports still retain memory proportional to history size.
httpLimits :: Int -> Int -> Either TargetError HttpLimits
httpLimits timeoutMicros maxBytes
  | timeoutMicros > 0 && timeoutMicros <= 300000000 && maxBytes > 0 && maxBytes <= 16777216 = Right (HttpLimits timeoutMicros maxBytes)
  | otherwise = Left InvalidHttpLimits

defaultHttpLimits :: HttpLimits
defaultHttpLimits = HttpLimits 30000000 1048576

targetConfig :: TargetKey -> DirectEndpoint -> ServerId -> LedgerNamespace -> LedgerBinding -> Credentials -> HttpLimits -> TargetConfig
targetConfig key endpoint identity = TargetConfig key endpoint (DirectServer identity)

targetKeyText :: TargetKey -> Text
targetKeyText (TargetKey value) = value

endpointText :: DirectEndpoint -> Text
endpointText (DirectEndpoint value) = value

serverIdText :: ServerId -> Text
serverIdText (ServerId value) = value

queryIdText :: QueryId -> Text
queryIdText (QueryId value) = value

ledgerIdText :: LedgerId -> Text
ledgerIdText (LedgerId value) = value

ledgerNamespaceText :: LedgerNamespace -> Text
ledgerNamespaceText (LedgerNamespace value) = value

valid :: Int -> (Char -> Bool) -> Text -> Bool
valid limit allowed value = not (Text.null value) && Text.length value <= limit && Text.all allowed value

lowerDigit :: Char -> Bool
lowerDigit c = isAsciiLower c || digit c

digit :: Char -> Bool
digit c = c >= '0' && c <= '9'

uuid :: Text -> Bool
uuid value = map Text.length (Text.splitOn "-" value) == [8, 4, 4, 4, 12] && Text.all (\c -> c == '-' || digit c || (c >= 'a' && c <= 'f')) value

identityServerId :: ServerIdentity -> ServerId
identityServerId (ServerIdentity value _ _) = value

identityVersion :: ServerIdentity -> Text
identityVersion (ServerIdentity _ value _) = value

identityHostName :: ServerIdentity -> Text
identityHostName (ServerIdentity _ _ value) = value

-- | Fresh client-generated UUID for a one-time first-use authorization. Persist
-- this value before submission and retain it after interrupted initialization.
newLedgerId :: IO LedgerId
newLedgerId = LedgerId <$> freshUuid

-- | Read-only nonsecret configuration identity for application adapters.
configuredTargetKey :: TargetConfig -> TargetKey
configuredTargetKey = configKey

-- | Binding mode is explicit; this accessor grants no initialization authority.
configuredLedgerBinding :: TargetConfig -> LedgerBinding
configuredLedgerBinding = configBinding

-- | The admitted server topology, without credentials.
configuredTopology :: TargetConfig -> TargetTopology
configuredTopology = configTopology

clusterName :: Text -> Either TargetError ClusterName
clusterName value
  | valid 128 (\c -> lowerDigit c || c `elem` ("_-" :: String)) value && maybe False (\(c, _) -> isAsciiLower c || c == '_') (Text.uncons value) = Right (ClusterName value)
  | otherwise = Left InvalidClusterName

clusterNameText :: ClusterName -> Text
clusterNameText (ClusterName value) = value

-- | Every expected replica participates in acknowledged writes. The deadline must
-- leave room for bounded server waits and a complete HTTP error response.
replicatedTargetConfig :: TargetKey -> DirectEndpoint -> ClusterName -> NonEmpty ServerId -> LedgerNamespace -> LedgerBinding -> Credentials -> HttpLimits -> Either TargetError TargetConfig
replicatedTargetConfig key endpoint cluster replicas namespace binding credentials limits@(HttpLimits micros _)
  | Set.size (Set.fromList (NE.toList replicas)) /= NE.length replicas = Left DuplicateReplica
  | micros < 5000000 = Left InvalidHttpLimits
  | otherwise = Right (TargetConfig key endpoint (ReplicatedCluster cluster replicas) namespace binding credentials limits)