{-|
Module      : Gargantext.Core.NodeStory
Description : NodeStory
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

A Node Story is a Map between NodeId and an Archive (with state,
version and history) for that node.

Couple of words on how this is implemented.

First version used files which stored Archive for each NodeId in a
separate .cbor file.

For performance reasons, it is rewritten to use the DB.

The table `node_stories` contains two columns: `node_id` and
`archive`.

Next, it was observed that `a_history` in `Archive` takes much
space. So a new table was created, `node_story_archive_history` with
columns: `node_id`, `ngrams_type_id`, `patch`. This is because each
history item is in fact a map from `NgramsType` to `NgramsTablePatch`
(see the `NgramsStatePatch'` type).

Moreover, since in `G.A.Ngrams.commitStatePatch` we use current state
only, with only recent history items, I concluded that it is not
necessary to load whole history into memory. Instead, it is kept in DB
(history is immutable) and only recent changes are added to
`a_history`. Then that record is cleared whenever `Archive` is saved.

Please note that

TODO:
- remove
- filter
- charger les listes
-}

{-# LANGUAGE Arrows #-}
{-# LANGUAGE ConstraintKinds   #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Gargantext.Core.NodeStory
  ( module Gargantext.Core.NodeStory.Types
  , getNodesArchiveHistory
  , Archive(..)
  , ArchiveStateForest
  , nodeExists
  , getNodesIdWithType
  , mkNodeStoryEnv
  , upsertNodeStories
  , getNodeStory'
  , nodeStoriesQuery
  , currentVersion
  , archiveStateFromList
  , archiveStateToList
  , fixNodeStoryVersions
  , getParentsChildren
  -- * Operations on trees and forests
  , buildForest
  , pruneForest
  ) where

import Control.Lens ((%~), non, _Just, at, over, Lens')
import Data.ListZipper
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Database.PostgreSQL.Simple qualified as PGS
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.ToField qualified as PGS
import Gargantext.API.Ngrams.Types
import Gargantext.Core.NodeStory.DB
import Gargantext.Core.NodeStory.Types
import Gargantext.Core.Text.Ngrams qualified as Ngrams
import Gargantext.Database.Admin.Types.Node ( ListId, NodeId(..) )
import Gargantext.Database.Admin.Config ()
import Gargantext.Database.Prelude
import Gargantext.Prelude hiding (to)
import Data.Tree

class HasNgramChildren e where
  ngramsElementChildren :: Lens' e (MSet NgramsTerm)

instance HasNgramChildren NgramsRepoElement where
  ngramsElementChildren = nre_children

instance HasNgramChildren NgramsElement where
  ngramsElementChildren = ne_children

class HasNgramParent e where
  ngramsElementParent :: Lens' e (Maybe NgramsTerm)

instance HasNgramParent NgramsRepoElement where
  ngramsElementParent = nre_parent

instance HasNgramParent NgramsElement where
  ngramsElementParent = ne_parent

-- | A 'Forest' (i.e. a list of trees) that models a hierarchy of ngrams terms, possibly grouped in
-- a nested fashion, all wrapped in a 'Zipper'. Why using a 'Zipper'? Because when traversing the
-- forest (for example to fix the children in case of dangling imports) we need sometimes to search
-- things into the forest, but crucially we do not want to search also inside the tree we are
-- currently iterating on! A zipper gives exactly that, i.e. a way to \"focus\" only on a particular
-- piece of a data structure.
type ArchiveStateForest = ListZipper (Tree (NgramsTerm, NgramsRepoElement))

buildForestsFromArchiveState :: NgramsState' -> Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement))
buildForestsFromArchiveState = Map.map buildForest

destroyArchiveStateForest :: Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement)) -> NgramsState'
destroyArchiveStateForest = Map.map destroyForest

-- | Builds an ngrams forest from the input ngrams table map.
buildForest :: forall e. HasNgramChildren e => Map NgramsTerm e -> Forest (NgramsTerm, e)
buildForest mp = unfoldForest mkTreeNode (Map.toList mp)
  where
    mkTreeNode :: (NgramsTerm, e) -> ((NgramsTerm, e), [(NgramsTerm, e)])
    mkTreeNode (k, el) = ((k, el), mapMaybe findChildren $ mSetToList (el ^. ngramsElementChildren))

    findChildren :: NgramsTerm -> Maybe (NgramsTerm, e)
    findChildren t = Map.lookup t mp <&> \el -> (t, el)

-- | Folds an Ngrams forest back to a table map.
-- This function doesn't aggregate information, but merely just recostructs the original
-- map without loss of information. To perform operations on the forest, use the appropriate
-- functions.
destroyForest :: Forest (NgramsTerm, NgramsRepoElement) -> Map NgramsTerm NgramsRepoElement
destroyForest f = Map.fromList . map (foldTree destroyTree) $ f
  where
    destroyTree :: (NgramsTerm, NgramsRepoElement)
                -> [(NgramsTerm, NgramsRepoElement)]
                -> (NgramsTerm, NgramsRepoElement)
    destroyTree (k, rootEl) childrenEl = (k, squashElements rootEl childrenEl)

    squashElements :: e -> [(NgramsTerm, e)] -> e
    squashElements r _ = r

-- | Prunes the input 'Forest' of 'NgramsElement' by keeping only the roots, i.e. the
-- nodes which has no children /AND/ they do not appear in any other 'children' relationship.
-- /NOTE ON IMPLEMENTATION:/ The fast way to do this is to simply filter each tree, ensuring
-- that we keep only trees which root has no parent or root (i.e. it's a root itself!) and this
-- will work only under the assumption that the input 'Forest' has been built correctly, i.e.
-- with the correct relationships specified, or this will break.
pruneForest :: HasNgramParent e => Forest e -> Forest e
pruneForest = filter (\(Node r _) -> isNothing (r ^. ngramsElementParent))


getNodeStory' :: NodeId -> DBQuery err x ArchiveList
getNodeStory' nId = do
  --res <- withResource pool $ \c -> runSelect c query :: IO [NodeStoryPoly NodeId Version Int Int NgramsRepoElement]
  res <- mkPGQuery nodeStoriesQuery (PGS.Only $ PGS.toField nId) :: DBQuery err x [(Version, Ngrams.NgramsType, NgramsTerm, NgramsRepoElement)]
  -- We have multiple rows with same node_id and different (ngrams_type_id, ngrams_id).
  -- Need to create a map: {<node_id>: {<ngrams_type_id>: {<ngrams_id>: <data>}}}
  let dbData = map (\(version, ngramsType, ngrams, ngrams_repo_element) ->
                      Archive { _a_version = version
                              , _a_history = []
                              , _a_state   = Map.singleton ngramsType $ Map.singleton ngrams ngrams_repo_element }) res
  -- NOTE Sanity check: all versions in the DB should be the same
   -- TODO Maybe redesign the DB so that `node_stories` has only
   -- `node_id`, `version` and there is a M2M table
   -- `node_stories_ngrams` without the `version` colum? Then we would
   -- have `version` in only one place.
  pure $ foldl' combine initArchive dbData
  where
    -- NOTE (<>) for Archive doesn't concatenate states, so we have to use `combine`
    combine a1 a2 = a1 & a_state %~ combineState (a2 ^. a_state)
                       & a_version .~ (a2 ^. a_version)  -- version should be updated from list, not taken from the empty Archive


getNodeStory :: NodeId -> DBQuery err x NodeListStory
getNodeStory nId = do
  a <- getNodeStory' nId
  pure $ NodeStory $ Map.singleton nId a

-- |Functions to convert archive state (which is a `Map NgramsType
--  (Map NgramsTerm NgramsRepoElement`)) to/from a flat list
archiveStateToList :: NgramsState' -> ArchiveStateList
archiveStateToList s = mconcat $ (\(nt, ntm) -> (\(n, nre) -> (nt, n, nre)) <$> Map.toList ntm) <$> Map.toList s

archiveStateFromList :: ArchiveStateList -> NgramsState'
archiveStateFromList l = Map.fromListWith (<>) $ (\(nt, t, nre) -> (nt, Map.singleton t nre)) <$> l

archiveStateSet :: ArchiveStateList -> ArchiveStateSet
archiveStateSet lst = Set.fromList $ (\(nt, term, _) -> (nt, term)) <$> lst

archiveStateListFilterFromSet :: ArchiveStateSet -> ArchiveStateList -> ArchiveStateList
archiveStateListFilterFromSet set =
  filter (\(nt, term, _) -> Set.member (nt, term) set)

-- | This function inserts whole new node story and archive for given node_id.
insertNodeStory :: NodeId -> ArchiveList -> DBUpdate err ()
insertNodeStory nId a = do
  insertArchiveStateList nId (a ^. a_version) (archiveStateToList $ a ^. a_state)

-- | This function updates the node story and archive for given node_id.
updateNodeStory :: NodeId -> ArchiveList -> ArchiveList -> DBUpdate err ()
updateNodeStory nodeId currentArchive newArchive = do
  -- STEPS

  -- 0. We assume we're inside an advisory lock

  -- 1. Find differences (inserts/updates/deletes)
  let currentList = archiveStateToList $ currentArchive ^. a_state
  let newList = archiveStateToList $ newArchive ^. a_state
  let currentSet = archiveStateSet currentList
  let newSet = archiveStateSet newList

  -- printDebug "[updateNodeStory] new - current = " $ Set.difference newSet currentSet
  let inserts = archiveStateListFilterFromSet (Set.difference newSet currentSet) newList
  -- printDebug "[updateNodeStory] inserts" inserts

  -- printDebug "[updateNodeStory] current - new" $ Set.difference currentSet newSet
  let deletes = archiveStateListFilterFromSet (Set.difference currentSet newSet) currentList
  -- printDebug "[updateNodeStory] deletes" deletes

  -- updates are the things that are in new but not in current
  let commonSet = Set.intersection currentSet newSet
  let commonNewList = archiveStateListFilterFromSet commonSet newList
  let commonCurrentList = archiveStateListFilterFromSet commonSet currentList
  let updates = Set.toList $ Set.difference (Set.fromList commonNewList) (Set.fromList commonCurrentList)
  -- printDebug "[updateNodeStory] updates" $ Text.unlines $ (Text.pack . show) <$> updates

  -- 2. Perform inserts/deletes/updates
  -- printDebug "[updateNodeStory] applying inserts" inserts
  insertArchiveStateList nodeId (newArchive ^. a_version) inserts
  --printDebug "[updateNodeStory] insert applied" ()
    --TODO Use currentArchive ^. a_version in delete and report error
  -- if entries with (node_id, ngrams_type_id, ngrams_id) but
  -- different version are found.
  deleteArchiveStateList nodeId deletes
  --printDebug "[updateNodeStory] delete applied" ()
  updateArchiveStateList nodeId (newArchive ^. a_version) updates
  --printDebug "[updateNodeStory] update applied" ()
  pure ()

upsertNodeStories :: NodeId -> ArchiveList -> DBUpdate err ()
upsertNodeStories nodeId newArchive = do
  -- printDebug "[upsertNodeStories] START nId" nId
  -- printDebug "[upsertNodeStories] locking nId" nId
  (NodeStory m) <- getNodeStory nodeId
  case Map.lookup nodeId m of
    Nothing ->
      void $ insertNodeStory nodeId newArchive
    Just currentArchive ->
      void $ updateNodeStory nodeId currentArchive newArchive

  -- 3. Now we need to set versions of all node state to be the same
  updateNodeStoryVersion nodeId newArchive

  -- printDebug "[upsertNodeStories] STOP nId" nId

-- | Returns a `NodeListStory`, updating the given one for given `NodeId`
nodeStoryInc :: NodeListStory -> NodeId -> DBQuery err x NodeListStory
nodeStoryInc ns@(NodeStory nls) nId = do
  case Map.lookup nId nls of
    Nothing -> do
      NodeStory nls' <- getNodeStory nId
      pure $ NodeStory $ Map.unionWith archiveAdvance nls' nls
    Just _ -> pure ns

-- | NgramsRepoElement contains, in particular, `nre_list`,
-- `nre_parent` and `nre_children`. We want to make sure that all
-- children entries (i.e. ones that have `nre_parent`) have the same
-- `list` as their parent entry.
-- NOTE(adn) Currently unused, see !424 for context.
_fixChildrenInNgrams :: NgramsState' -> NgramsState'
_fixChildrenInNgrams ns = archiveStateFromList $ nsParents <> nsChildrenFixed
  where
    (nsParents, nsChildren) = getParentsChildren ns
    parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_list)) <$> nsParents

    nsChildrenFixed = (\(nt, t, nre) ->
                         ( nt
                         , t
                         , nre & nre_list %~
                            (\l -> parentNtMap ^. at (nre ^. nre_parent . _Just) . non l)
                         )
                      ) <$> nsChildren

-- | (#281) Sometimes, when we upload a new list, a child can be left
-- without a parent. Find such ngrams and set their 'root' and
-- 'parent' to 'Nothing'.
fixChildrenWithNoParent :: Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement))
                        -> Map Ngrams.NgramsType (Forest (NgramsTerm, NgramsRepoElement))
fixChildrenWithNoParent = Map.map go
  where
    -- If the forest is somehow empty, do nothing. Otherwise, build a zipper and run
    -- the algorithm.
    go :: Forest (NgramsTerm, NgramsRepoElement)
       -> Forest (NgramsTerm, NgramsRepoElement)
    go fs = case zipper fs of
      Nothing  -> fs
      Just zfs -> maybe mempty toList $ execListZipperOp fixDanglingChildrenInForest zfs

    fixDanglingChildrenInForest :: ListZipperOp (Tree (NgramsTerm, NgramsRepoElement)) ()
    fixDanglingChildrenInForest = do
      z@(ListZipper l a r) <- get
      when (isOrphan (l <> r) a) $ void $ modifyFocus detachFromParent
      unless (atEnd z) $ do
        moveRight
        fixDanglingChildrenInForest

    detachFromParent :: Tree (NgramsTerm, NgramsRepoElement) -> Tree (NgramsTerm, NgramsRepoElement)
    detachFromParent (Node (k,v) el) = Node (k, v & nre_root   .~ Nothing & nre_parent .~ Nothing) el

    isOrphan :: Forest (NgramsTerm, NgramsRepoElement)
             -- ^ The rest of the forest, i.e. the list of trees
             -- except the input one.
             -> Tree (NgramsTerm, NgramsRepoElement)
             -- ^ The tree we are currently focusing.
             -> Bool
             -- ^ True if the root of the tree refers to
             -- a node that is not listed as any children of
             -- the subtrees, and yet it has a non-null parent
             -- or root.
    isOrphan restOfTheForest (Node (k,v) _) =
      (isJust (_nre_parent v) || isJust (_nre_root v)) &&
      not (isChildInForest (k,v) restOfTheForest)

    -- | Returns 'True' if the input child can be found in the tree.
    isChildInForest :: Eq e => e -> Forest e -> Bool
    isChildInForest _ []     = False
    isChildInForest e (x:xs) =
      case e == rootLabel x of
        True  -> True
        False -> isChildInForest e (subForest x) || isChildInForest e xs

-- | Sometimes children can also become parents (e.g. #313). Find such
-- | children and remove them from the list.
-- NOTE(adn) Currently unused, see !424 for context.
_fixChildrenDuplicatedAsParents :: NgramsState' -> NgramsState'
_fixChildrenDuplicatedAsParents ns = archiveStateFromList $ nsChildren <> nsParentsFixed
  where
    (nsParents, nsChildren) = getParentsChildren ns
    parentNtMap = Map.fromList $ (\(_nt, t, nre) -> (t, nre ^. nre_children & mSetToSet)) <$> nsParents
    parentsSet = Set.fromList $ Map.keys parentNtMap

    nsParentsFixed = (\(nt, t, nre) ->
                       ( nt
                       , t
                       , over nre_children
                             (\c -> mSetFromSet $ Set.difference (mSetToSet c) parentsSet)
                             nre ) ) <$> nsParents

getParentsChildren :: NgramsState' -> (ArchiveStateList, ArchiveStateList)
getParentsChildren ns = (nsParents, nsChildren)
  where
    nls = archiveStateToList ns

    nsParents = filter (\(_nt, _t, nre) -> isNothing $ nre ^. nre_parent) nls
    nsChildren = filter (\(_nt, _t, nre) -> isJust $ nre ^. nre_parent) nls

------------------------------------

mkNodeStoryEnv :: NodeStoryEnv err
mkNodeStoryEnv = do
  let saver_immediate nId a = do
        -- |NOTE Fixing a_state is kinda a hack. We shouldn't land
        -- |with bad state in the first place.
        upsertNodeStories nId $
          a & a_state %~ (
                    destroyArchiveStateForest
                  . fixChildrenWithNoParent
                  . buildForestsFromArchiveState
                  )
  let archive_saver_immediate nId a = do
        insertNodeArchiveHistory nId (a ^. a_version) $ reverse $ a ^. a_history
        pure $ a & a_history .~ []

  NodeStoryEnv { _nse_saver = saver_immediate
               , _nse_archive_saver = archive_saver_immediate
               , _nse_getter = getNodeStory'
               , _nse_getter_multi = \nIds -> foldM nodeStoryInc (NodeStory Map.empty) nIds
               }

currentVersion :: ListId -> DBQuery err x Version
currentVersion listId = do
  nls <- getNodeStory listId
  pure $ nls ^. unNodeStory . at listId . _Just . a_version


-----------------------------------------

-- | To be called from the REPL
fixNodeStoryVersions :: (HasNodeStory env err m, IsDBCmd env err m) => m ()
fixNodeStoryVersions = runDBTx $ do
  nIds <- mkPGQuery [sql| SELECT id FROM nodes WHERE ? |] (PGS.Only True) :: DBQuery err x [PGS.Only Int64]
  -- printDebug "[fixNodeStoryVersions] nIds" nIds
  mapM_ (\(PGS.Only nId) -> do
      -- printDebug "[fixNodeStoryVersions] nId" nId
      updateVer Ngrams.Authors nId
      updateVer Ngrams.Institutes nId
      updateVer Ngrams.Sources nId
      updateVer Ngrams.NgramsTerms nId
    ) nIds
  where
    maxVerQuery :: PGS.Query
    maxVerQuery = [sql| SELECT max(version)
                      FROM node_stories
                      WHERE node_id = ?
                        AND ngrams_type_id = ? |]
    updateVerQuery :: PGS.Query
    updateVerQuery = [sql| UPDATE node_stories
                         SET version = ?
                         WHERE node_id = ?
                           AND ngrams_type_id = ? |]
    updateVer :: Ngrams.NgramsType -> Int64 -> DBUpdate err ()
    updateVer ngramsType nId = do
      maxVer <- mkPGQuery maxVerQuery (nId, ngramsType) :: DBUpdate err [PGS.Only (Maybe Int64)]
      case maxVer of
        [] -> pure ()
        [PGS.Only Nothing] -> pure ()
        [PGS.Only (Just maxVersion)] -> do
          void $ mkPGUpdate updateVerQuery (maxVersion, nId, ngramsType)
        _ -> panicTrace "Should get only 1 result!"
