{-
  Copyright (c) Meta Platforms, Inc. and affiliates.
  All rights reserved.

  This source code is licensed under the BSD-style license found in the
  LICENSE file in the root directory of this source tree.
-}

{- |
This module focuses on determining which predicate should be transformed
into which by looking at the contents of schemas and at the evolution
relationships between schemas.
-}
{-# LANGUAGE CPP #-}
module Glean.Schema.Evolve
  ( validateResolvedEvolutions
  , directSchemaEvolutions
  , calcEvolutions
  , validateEvolutions
  , visiblePredicates
  , mapVisible
  , VisiblePredicates
  , visibleDefined
  , canBeStored
  ) where

import Control.Applicative
import Control.Monad
#if !MIN_VERSION_base(4,16,0)
import Data.Foldable
#endif
import Data.Graph
import Data.Hashable
import qualified Data.HashSet as HashSet
import Data.HashSet (HashSet)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.List
import Data.List.Extra (nubOrdOn)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (listToMaybe)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as Text

import Glean.Angle.Types
import Glean.Display
import Glean.Schema.Types
import Glean.Schema.Util

{- Note [Schema Evolutions]

An 'schema evolution' is a non-commuting transitive relationship between two
schemas. It is established by a source code annotation saying:

    schema A evolves B

It establishes a 'predicate evolution' relationship between all predicates
exported by B and predicates exported by A if they have the same name. Schema
evolutions must form a graph with no cycles.

A 'predicate evolution' is a reflexive, commutative, non-transitive
relationship between two predicates. It means that facts from one predicate can
be transformed into facts from the other.

It is established in two cases:

  - predicate P evolves predicate Q if the schema containing P evolves the
  schema containing Q and both P and Q have the same name.
  This is caused by a source code annotation.

  - predicate P evolves predicate Q if they are defined in schemas with the
  same SchemaRef and have the same name but different hashes.
  This is caused by a version-less schema migration and the two instances
  live in different ProcessedSchema.

NB: Although 'predicate evolution' is not a transitive relationship, we
expect it to work in all transitively evolved predicates because we want
'schema evolution' to be transitive.

Example of why predicate evolution is not transitive:
  predicate P.1 = { a : maybe nat }
  predicate P.2 = {}
  predicate P.3 = { a : maybe string }

P.2 can evolve P.1 and P.3 can evolve P.2, but P.3 cannot evolve P.1.
-}

-- | As specified by a `schema x evolves y` line.
-- Does not take the db's content into account.
-- value evolves key
directSchemaEvolutions
  :: [ResolvedSchemaRef]
  -> Either Text (Map SchemaRef SchemaRef)
directSchemaEvolutions schemas =
  Map.traverseWithKey checkMultipleEvolves $
  Map.fromListWith (++)
    [ (evolved, [schemaRef resolved])
    | resolved <- schemas
    , evolved <- Set.toList $ resolvedSchemaEvolves resolved
    ]
  where
  checkMultipleEvolves old newList =
    case nub newList of
      [new] -> Right new
      _     -> Left $ "multiple schemas evolve "
        <> showSchemaRef old
        <> ": "
        <> Text.unwords (map showSchemaRef newList)

-- | Visible predicates which can be evolved.
data VisiblePredicates p = VisiblePredicates
  { visibleDefined :: HashSet p
  , visibleReexported :: HashSet p
  }

visiblePredicates :: ResolvedSchemaRef -> VisiblePredicates PredicateRef
visiblePredicates ResolvedSchema{..} = VisiblePredicates
  { visibleDefined = evolvable resolvedSchemaPredicates
  , visibleReexported = evolvable resolvedSchemaReExportedPredicates
  }
  where
  evolvable :: HashMap PredicateRef ResolvedPredicateDef -> HashSet PredicateRef
  evolvable = HashSet.fromList . filter stored . HashMap.keys

  stored ref =
    maybe True (canBeStored . derivingDefDeriveInfo) $
      HashMap.lookup ref resolvedSchemaDeriving

canBeStored :: DerivingInfo a -> Bool
canBeStored = \case
  Derive DeriveOnDemand _ -> False
  Derive DerivedAndStored _ -> True
  Derive DeriveIfEmpty _ -> True
  NoDeriving -> True

mapVisible
  :: (Eq q, Hashable q)
  => (p -> q)
  -> VisiblePredicates p
  -> VisiblePredicates q
mapVisible f (VisiblePredicates d r) =
  VisiblePredicates (HashSet.map f d) (HashSet.map f r)

instance (Eq p, Hashable p) => Semigroup (VisiblePredicates p) where
  VisiblePredicates d r <> VisiblePredicates d' r' =
    VisiblePredicates (d <> d') (r <> r')

instance (Eq p, Hashable p) => Monoid (VisiblePredicates p) where
  mappend = (<>)
  mempty = VisiblePredicates mempty mempty

-- | Given evolutions between schemas and evolutions between instances of the
-- same predicate, calculate the final instance-to-instance predicate
-- evolutions.
calcEvolutions
  :: forall p. (Eq p, Ord p, Hashable p, ShowRef p)
  => (p -> PredicateRef)
  -> Map PredicateRef [p]          -- ^ all predicates by ref
  -> Map SchemaRef (VisiblePredicates p) -- ^ all predicates by schema ref
  -> Map SchemaRef SchemaRef       -- ^ evolutions from src code directives
  -> Map PredicateRef p            -- ^ evolutions from versionless migrations
  -> Either Text (HashMap p p)
calcEvolutions toRef byPredRef bySchemaRef schemaEvolutions autoEvolutions =
  case cycles evolutions of
    [] -> Right evolutions
    []:_ -> error "calcEvolutions"
    (x:xs):_ -> Left $ "found a cycle in predicate evolutions: " <>
      Text.intercalate " -> " (map showRef $ x:xs ++ [x])
  where
  cycles :: Ord a => HashMap a a -> [[a]]
  cycles hm = [ cycle | CyclicSCC cycle <- scc]
    where
    scc = stronglyConnComp [ (k,k,[v]) | (k, v) <- HashMap.toList hm ]

  evolutions = fromSourceAnnotations `HashMap.union` fromVersionlessMigrations

  fromVersionlessMigrations :: HashMap p p
  fromVersionlessMigrations = HashMap.fromList
    [ (old, new)
    | (ref, preds) <- Map.toList byPredRef
    , old <- preds
    , Just new <- [Map.lookup ref autoEvolutions]
    , new /= old
    ]

  fromSourceAnnotations :: HashMap p p
  fromSourceAnnotations =
    HashMap.unions
    $ map concrete
    $ map (uncurry match)
    $ Map.toList schemaEvolutions
    where
      concrete :: HashMap PredicateRef PredicateRef -> HashMap p p
      concrete = HashMap.fromList . concatMap expand . HashMap.toList

      expand :: (PredicateRef, PredicateRef) -> [(p,p)]
      expand (from, to) =
        [ (from', to')
        | from' <- allInstances from
        , Just to' <- [mostEvolvedInstance to]
        ]

      allInstances :: PredicateRef -> [p]
      allInstances ref = Map.findWithDefault [] ref byPredRef

      mostEvolvedInstance :: PredicateRef -> Maybe p
      mostEvolvedInstance ref = evolved <|> anyInstance
        where
        evolved = Map.lookup ref autoEvolutions
        anyInstance = listToMaybe =<< Map.lookup ref byPredRef

  match :: SchemaRef -> SchemaRef -> HashMap PredicateRef PredicateRef
  match old new = HashMap.fromList
    [ (rold, rnew)
    | rold <- predicates old
    , Just rnew <- [Map.lookup (name rold) newByName]
    , rnew /= rold -- avoid re-exports evolving themselves
    ]
    where
    newByName :: Map Name PredicateRef
    newByName = Map.fromList [ (name ref, ref) | ref <- predicates new ]

  predicates :: SchemaRef -> [PredicateRef]
  predicates sref =
    -- defined override reexported
    nubOrdOn name
      $ map toRef
      $ HashSet.toList defined <> HashSet.toList reexported
    where
      VisiblePredicates defined reexported =
        Map.findWithDefault mempty sref bySchemaRef

  name :: PredicateRef -> Name
  name = predicateRef_name

-- | Check schemas for compatibility and map each predicate to their
-- evolved counterpart in the the evolvedBy map.
--
-- This is abstracted over the type of predicates and types, because
-- we use it in two different ways:
--
-- 1. To check the validity of "schema A evolves B" declarations.  This
--    check is performa at schema resolution time, so
--       p = PredicateRef
--       t = TypeRef
--
-- 2. To check compatibility between complete schemas when a new
--    schema instance is added to the SchemaIndex. We're dealing with
--    complete hashed schemas in this case, so
--       p = PredicateId
--       t = TypeId
--
validateEvolutions
  :: (Eq p, Eq t, ShowRef p, ShowRef t,
      Hashable p, Hashable t, Display p, Display t)
  => Maybe (p -> Bool)               -- ^ does the db has facts of p
  -> HashMap t (TypeDef_ st p t)        -- ^ types to their definitions
  -> HashMap p (PredicateDef_ s st p t) -- ^ predicates to their definitions
  -> HashMap p p                     -- ^ predicate evolutions
  -> Either Text ()
validateEvolutions mHasFacts types preds evolutions =
  void $ HashMap.traverseWithKey validate evolutions
  where
    validate old new =
      let PredicateDef _ oldKey oldVal _ _ = preds HashMap.! old
          PredicateDef _ newKey newVal _ _ = preds HashMap.! new
          keyErr = newKey `canEvolve'` oldKey
          valErr = newVal `canEvolve'` oldVal
      in
      case keyErr <|> valErr of
        Nothing -> Right ()
        Just err -> Left $
          "cannot evolve predicate " <> showRef old <>
          " into " <> showRef new <> ": " <> err

    canEvolve' = canEvolve types compatible

    compatible new old =
      case mHasFacts of
        Nothing ->
          -- Here we are validating an evolution graph without a database.
          -- Compatible predicates must ultimately evolve to the same
          -- PredicateRef. We ignore hashes because auto-evolutions will make
          -- all predicates with the same PredicateRef evolve to the same thing
          -- in a concrete database.
          ref (evolved new) == ref (evolved old)
        Just hasFacts
            -- if there are no facts, there will be no transformation so all
            -- types are considered compatible.
          | not (hasFacts old) -> True
            -- there will be a transformation so the evolutions map should have
            -- an exact match.
          | otherwise ->
            HashMap.lookupDefault old old evolutions
              ==  HashMap.lookupDefault new new evolutions

    ref p = predicateDefRef $ preds HashMap.! p

    -- get most evolved version of a predicate
    evolved p = case HashMap.lookup p evolutions of
      Nothing -> p
      Just p' -> if p' == p then p else evolved p'


-- | Create a mapping from a schema to the schema that evolves it. This will
--  - check if any schema is evolved by multiple schemas.
--  - check if all schema evolutions are legal.
--
-- If 'B evolves A' and 'C evolves A', when a query for A comes we won't
-- know whether to serve facts from C or from B. Therefore we disallow
-- multiple schemas to evolve a single one.
validateResolvedEvolutions :: [ResolvedSchemaRef] -> Either Text ()
validateResolvedEvolutions resolved = do
  schemaEvolutions <- directSchemaEvolutions resolved
  let autoEvolutions = mempty
  evolutions <- calcEvolutions
    id
    byRef
    bySchemaRef
    schemaEvolutions
    autoEvolutions

  validateEvolutions Nothing types preds evolutions
  where
    byRef :: Map PredicateRef [PredicateRef]
    byRef = Map.fromList [ (ref, [ref]) | ref <- HashMap.keys preds ]

    bySchemaRef :: Map SchemaRef (VisiblePredicates PredicateRef)
    bySchemaRef = Map.fromList
      [ (schemaRef schema, visiblePredicates schema)
      | schema <- resolved
      ]

    -- Later definitions override earlier ones in case of db overrides
    -- (is this really the case or are overrides added to a new ProcessedSchema?)
    preds :: HashMap PredicateRef
      (PredicateDef_ SrcSpan SrcSpan PredicateRef TypeRef)
    preds = HashMap.unions $ reverse $ map resolvedSchemaPredicates resolved

    types :: HashMap TypeRef ResolvedTypeDef
    types = HashMap.unions $ reverse $ map resolvedSchemaTypes resolved

data Opt = Option | FieldOpt

-- | Check if a type is backward and forward compatible.
--
-- For backward and forward compatibility the rules are:
--  - only add or remove fields with defaultable values
--  - if a field referencing a predicate is changed, it must be
--    to a compatible predicate reference.
--
-- Two predicate references are compatible if they evolve to the same predicate
-- or have the same PredicateRef.
canEvolve
  :: (Eq p, Eq t, ShowRef p, ShowRef t,
      Hashable p, Hashable t, Display p, Display t)
  => HashMap t (TypeDef_ s p t) -- ^ type definitions
  -> (p -> p -> Bool)         -- ^ whether two predicates are compatible
  -> Type_ s p t                -- ^ updated type
  -> Type_ s p t                -- ^ old type
  -> Maybe Text               -- ^ compatibility error
canEvolve types compatible new old = go new old
  where
    get ty = case HashMap.lookup ty types of
      Just v -> typeDefType v
      Nothing -> error $ "unknown type " <> Text.unpack (showRef ty)

    go (NamedTy _ new) (NamedTy _ old )
      | new == old = Nothing
      | otherwise = go (get new) (get old)
    go (NamedTy _ t) old = go (get t) old
    go new (NamedTy _ t) = go new (get t)
    go (MaybeTy new) (MaybeTy old) = go new old
    go ByteTy ByteTy = Nothing
    go NatTy NatTy = Nothing
    go StringTy StringTy = Nothing
    go BooleanTy BooleanTy = Nothing
    go (ArrayTy new) (ArrayTy old) = go new old
    go (SetTy new) (SetTy old) = go new old
    go (PredicateTy _ new) (PredicateTy _ old)
      | not (compatible new old) = Just
          $ "type changed from " <> showRef old
          <> " to " <> showRef new
      | otherwise = Nothing
    go (EnumeratedTy new) (EnumeratedTy old) =
      compareFieldList Option new' old'
      where
        new' = map unitOpt new
        old' = map unitOpt old
        unitOpt name = FieldDef name (RecordTy [])
    go (SumTy new) (SumTy old) = compareFieldList Option new old
    go (RecordTy new) (RecordTy old) = compareFieldList FieldOpt new old
    go (SetTy new) (ArrayTy old) = go new old
    go (ArrayTy new) (SetTy old) = go new old
    go new old = Just $ Text.pack $
      "type changed from " <>
        show (displayDefault old) <> " to " <>
        show (displayDefault new)

    compareFieldList optName new old =
      removedFieldsError <|> newRequiredFieldsError <|>
      asum (map compareField matchingFields)
      where
        names = map fieldDefName
        oldByName = Map.fromList (zip (names old) old)
        newByName = Map.fromList (zip (names new) new)
        matchingFields =
          [ (name, fNew, fOld)
          | FieldDef name fNew <- new
          , Just (FieldDef _ fOld) <- [Map.lookup name oldByName]
          ]
        compareField (name, new, old) = addLocation <$> go new old
          where
            addLocation err =
              "in " <> showOpt optName <> " '" <> name <> "', " <> err

        addedFields = Map.difference newByName oldByName
        removedFields = Map.difference oldByName newByName
        required fields = Map.filter (not . hasDefault . fieldDefType) fields
        hasDefault ty = case ty of
          MaybeTy _ -> True
          NatTy -> True
          StringTy -> True
          BooleanTy -> True
          ByteTy -> True
          ArrayTy _ -> True
          SetTy _ -> True
          RecordTy fields -> all (hasDefault . fieldDefType) fields
          EnumeratedTy{} -> True
          SumTy (first : _) -> hasDefault (fieldDefType first)
          NamedTy _ ty -> hasDefault (get ty)
          _ -> False

        newRequiredFields = Map.keys (required addedFields)
        removedRequiredFields = Map.keys (required removedFields)

        removedFieldsError = case optName of
          Option -> Nothing
          FieldOpt -> case removedRequiredFields  of
            [] -> Nothing
            fields -> Just $ "missing required " <> plural optName fields
              <> ": " <> Text.unwords fields

        newRequiredFieldsError = case optName of
          Option -> Nothing
          FieldOpt -> case newRequiredFields of
            [] -> Nothing
            _ -> Just $ Text.unlines
              [ Text.unwords [ "required" , plural optName newRequiredFields
                , "added:" , Text.unwords newRequiredFields ]
              , "For backward and forward compatibility, predicate evolutions"
                <> " require that all new fields are non-predicate types"
              ]

    plural s [_] = showOpt s
    plural s _ = showOpt s <> "s"
    showOpt Option = "option"
    showOpt FieldOpt = "field"