{-|
Module      : Gargantext.Database.Types.Nodes
Description : Main Types of Nodes in Database
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX

-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DerivingVia         #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeApplications #-}

-- {-# LANGUAGE DuplicateRecordFields #-}

module Gargantext.Database.Admin.Types.Node
  where

import Codec.Serialise (Serialise())
import Data.Aeson as JSON
import Data.Aeson.Types
import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField)
import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField)
import Database.PostgreSQL.Simple.ToRow (ToRow, toRow)
import Data.Csv qualified as Csv
import Data.Morpheus.Kind (SCALAR)
import Data.Morpheus.Types ( DecodeScalar(..), EncodeScalar(..), GQLType(KIND) )
import Data.Swagger
import Data.Text (pack, unpack)
import Data.Text qualified as T
import Data.Time (UTCTime)
import Data.TreeDiff
import Database.PostgreSQL.Simple.FromRow (FromRow, fromRow, field)
import Fmt ( Buildable(..) )
import Gargantext.Core (HasDBid(..))
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Core.Utils.Swagger (wellNamedSchema)
import Gargantext.Database.Schema.Context
import Gargantext.Database.Schema.Node ( NodePoly(Node), NodePolySearch(NodeSearch) )
import Gargantext.Prelude
import Gargantext.Prelude.Crypto.Hash (Hash)
import Opaleye (DefaultFromField, defaultFromField, SqlInt4, SqlText, Nullable, fromPGSFromField)
import Opaleye qualified as O
import Opaleye.TextSearch (SqlTSVector)
import Prelude qualified
import Servant hiding (Context)
import Test.QuickCheck.Arbitrary ( Arbitrary(arbitrary), arbitraryBoundedEnum )
import Test.QuickCheck (elements, Positive (getPositive))
import Test.QuickCheck.Instances.Text ()
import Test.QuickCheck.Instances.Time ()
import Text.Read (read)

-- | A class generalising over resource identifiers in gargantext
class ResourceId a where
  isPositive :: a -> Bool

-- | A unique identifier for users within gargantext. Note that the 'UserId' for users is
-- typically /different/ from their 'NodeId', as the latter tracks the resources being created,
-- whereas this one tracks only users.
newtype UserId = UnsafeMkUserId { _UserId :: Int }
  deriving stock (Show, Eq, Ord, Generic)
  deriving newtype (ToSchema, ToJSON, FromJSON, FromField, ToField, Hashable)

instance NFData UserId where
instance Serialise UserId where

-- The 'UserId' is isomprohic to an 'Int'.
instance GQLType UserId where
  type KIND UserId = SCALAR

instance EncodeScalar UserId where
  encodeScalar = encodeScalar . _UserId

instance DecodeScalar UserId where
  decodeScalar = fmap UnsafeMkUserId . decodeScalar

instance ResourceId UserId where
  isPositive = (> 0) . _UserId

instance Arbitrary UserId where
  arbitrary = UnsafeMkUserId . getPositive <$> arbitrary

instance DefaultFromField SqlInt4 UserId
  where
    defaultFromField = fromPGSFromField

type MasterUserId = UserId

type NodeTypeId   = Int
type NodeName     = Text
type ContextName  = Text

type TSVector     = Text
type ContextTitle  = Text


------------------------------------------------------------------------
-- | NodePoly indicates that Node has a Polymorphism Type
type Node    json = NodePoly    NodeId (Maybe Hash) NodeTypeId UserId (Maybe ParentId) NodeName UTCTime json
type Context json = ContextPoly NodeId (Maybe Hash) NodeTypeId UserId (Maybe ParentId) ContextTitle UTCTime json
type ContextOnlyId json = ContextPolyOnlyId NodeId json

-- | NodeSearch (queries)
-- type NodeSearch json   = NodePolySearch NodeId NodeTypeId UserId (Maybe ParentId) NodeName UTCTime json (Maybe TSVector)

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

instance (Typeable hyperdata, ToSchema hyperdata) =>
         ToSchema (NodePoly NodeId Hash NodeTypeId
                            (Maybe UserId)
                            ParentId NodeName
                            UTCTime hyperdata
                  ) where
  declareNamedSchema = wellNamedSchema "_node_"

instance (Typeable hyperdata, ToSchema hyperdata) =>
         ToSchema (NodePoly NodeId Hash NodeTypeId
                            UserId
                            (Maybe ParentId) NodeName
                            UTCTime hyperdata
                  ) where
  declareNamedSchema = wellNamedSchema "_node_"

instance (Typeable hyperdata, ToSchema hyperdata) =>
         ToSchema (NodePoly NodeId (Maybe Hash) NodeTypeId
                            UserId
                            (Maybe ParentId) NodeName
                            UTCTime hyperdata
                  ) where
  declareNamedSchema = wellNamedSchema "_node_"

instance (Typeable hyperdata, ToSchema hyperdata) =>
         ToSchema (NodePolySearch NodeId
                                  NodeTypeId
                                  (Maybe UserId)
                                  ParentId
                                  NodeName
                                  UTCTime
                                  hyperdata
                                  (Maybe TSVector)
                  ) where
  declareNamedSchema = wellNamedSchema "_ns_"

instance (Typeable hyperdata, ToSchema hyperdata) =>
         ToSchema (NodePolySearch NodeId
                                  NodeTypeId
                                  UserId
                                  (Maybe ParentId)
                                  NodeName
                                  UTCTime
                                  hyperdata
                                  (Maybe TSVector)
                  ) where
  declareNamedSchema = wellNamedSchema "_ns_"

instance (Arbitrary nodeId
         ,Arbitrary hashId
         ,Arbitrary toDBid
         ,Arbitrary userId
         ,Arbitrary nodeParentId
         , Arbitrary hyperdata
         ) => Arbitrary (NodePoly nodeId hashId toDBid userId nodeParentId
                                  NodeName UTCTime hyperdata) where
    --arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (arbitrary) (Just "")
    arbitrary = Node <$> arbitrary <*> arbitrary <*> arbitrary
                     <*> arbitrary <*> arbitrary <*> arbitrary
                     <*> arbitrary <*> arbitrary



instance (Arbitrary hyperdata
         ,Arbitrary nodeId
         ,Arbitrary toDBid
         ,Arbitrary userId
         ,Arbitrary nodeParentId
         ) => Arbitrary (NodePolySearch nodeId
                                        toDBid
                                        userId
                                        nodeParentId
                                        NodeName
                                        UTCTime
                                        hyperdata
                                        (Maybe TSVector)
                        ) where
    --arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (arbitrary) (Just "")
    arbitrary = NodeSearch <$> arbitrary
                           <*> arbitrary
                           <*> arbitrary
                           <*> arbitrary
                           <*> arbitrary
                           <*> arbitrary
                           <*> arbitrary
                           <*> arbitrary


instance (Arbitrary contextId
         ,Arbitrary hashId
         ,Arbitrary toDBid
         ,Arbitrary userId
         ,Arbitrary contextParentId
         , Arbitrary hyperdata
         ) => Arbitrary (ContextPoly contextId hashId toDBid userId contextParentId
                                  ContextName UTCTime hyperdata) where
    --arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (arbitrary) (Just "")
    arbitrary = Context <$> arbitrary <*> arbitrary <*> arbitrary
                        <*> arbitrary <*> arbitrary <*> arbitrary
                        <*> arbitrary <*> arbitrary

instance (Arbitrary hyperdata
         ,Arbitrary contextId
         ,Arbitrary toDBid
         ,Arbitrary userId
         ,Arbitrary contextParentId
         ) => Arbitrary (ContextPolySearch contextId
                                        toDBid
                                        userId
                                        contextParentId
                                        ContextName
                                        UTCTime
                                        hyperdata
                                        (Maybe TSVector)
                        ) where
    --arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (arbitrary) (Just "")
    arbitrary = ContextSearch <$> arbitrary
                              <*> arbitrary
                              <*> arbitrary
                              <*> arbitrary
                              <*> arbitrary
                              <*> arbitrary
                              <*> arbitrary
                              <*> arbitrary




------------------------------------------------------------------------
pgNodeId :: NodeId -> O.Column O.SqlInt4
pgNodeId = pgResourceId _NodeId

pgResourceId :: (a -> Int) -> a -> O.Column O.SqlInt4
pgResourceId id2int = O.sqlInt4 . id2int

pgContextId :: ContextId -> O.Column O.SqlInt4
pgContextId = pgResourceId _ContextId

------------------------------------------------------------------------
-- | A unique identifier for a /node/ in the gargantext tree. Every time
-- we create something in Gargantext (a user, a corpus, etc) we add a node
-- to a tree, and each node has its unique identifier. Note how nodes might
-- have also /other/ identifiers, to better qualify them.
newtype NodeId = UnsafeMkNodeId { _NodeId :: Int }
  deriving stock (Read, Generic, Eq, Ord)
  deriving newtype (Num, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField)
  deriving anyclass (ToExpr)

instance NFData NodeId where

instance ResourceId NodeId where
  isPositive = (> 0) . _NodeId

instance Buildable NodeId where
  build (UnsafeMkNodeId nid) = build nid

instance GQLType NodeId
instance Prelude.Show NodeId where
  show (UnsafeMkNodeId n) = "nodeId-" <> show n
instance Serialise NodeId
instance ToField NodeId where
  toField (UnsafeMkNodeId n) = toField n
instance ToRow NodeId where
  toRow (UnsafeMkNodeId i) = [toField i]
instance FromRow NodeId where
  fromRow = UnsafeMkNodeId <$> field


instance FromField NodeId where
  fromField fld mdata = do
    n <- UnsafeMkNodeId <$> fromField fld mdata
    if isPositive n
       then pure n
       else mzero
instance ToSchema NodeId

-- | An identifier for a 'Context' in gargantext.
newtype ContextId = UnsafeMkContextId { _ContextId :: Int }
  deriving stock   (Show, Eq, Ord, Generic)
  deriving newtype (Csv.ToField, ToJSONKey, FromJSONKey, ToJSON, FromJSON, ToField, ToSchema, Hashable)
  deriving anyclass ToExpr
  deriving FromField via NodeId

instance ToParamSchema ContextId
instance NFData ContextId

instance Arbitrary ContextId where
  arbitrary = UnsafeMkContextId . getPositive <$> arbitrary

instance FromHttpApiData ContextId where
  parseUrlPiece n = pure $ UnsafeMkContextId $ (read . cs) n
instance ToHttpApiData ContextId where
  toUrlPiece (UnsafeMkContextId n) = toUrlPiece n

newtype NodeContextId = UnsafeMkNodeContextId { _NodeContextId :: Int }
  deriving stock (Read, Generic, Eq, Ord)
  deriving newtype (Num, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField)
  deriving anyclass (ToExpr)


--instance Csv.ToField NodeId where
--  toField (NodeId nodeId) = Csv.toField nodeId

unNodeId :: NodeId -> Int
unNodeId = _NodeId

-- | Converts a 'NodeId' into a 'ContextId'.
-- FIXME(adn) We should audit the usage of this function,
-- to make sure that a ContextId and a NodeId are /really/
-- conceptually the same thing.
nodeId2ContextId :: NodeId -> ContextId
nodeId2ContextId = UnsafeMkContextId . _NodeId

contextId2NodeId :: ContextId -> NodeId
contextId2NodeId = UnsafeMkNodeId . _ContextId

------------------------------------------------------------------------
------------------------------------------------------------------------
instance FromHttpApiData NodeId where
  parseUrlPiece n = pure $ UnsafeMkNodeId $ (read . cs) n
instance ToHttpApiData NodeId where
  toUrlPiece (UnsafeMkNodeId n) = toUrlPiece n
instance ToParamSchema NodeId

-- | It makes sense to generate only positive ids.
instance Arbitrary NodeId where
  arbitrary = UnsafeMkNodeId . getPositive <$> arbitrary

type ParentId    = NodeId
type CorpusId    = NodeId
type CommunityId = NodeId
type ListId      = NodeId
type DocumentId  = NodeId
type DocId       = NodeId
type RootId      = NodeId
type MasterCorpusId = CorpusId
type UserCorpusId   = CorpusId

type GraphId  = NodeId
type PhyloId  = NodeId
type AnnuaireId = NodeId
type ContactId  = NodeId

------------------------------------------------------------------------
data Status  = Status { status_failed    :: !Int
                      , status_succeeded :: !Int
                      , status_remaining :: !Int
                      } deriving (Show, Generic)
$(deriveJSON (unPrefix "status_") ''Status)

instance Arbitrary Status where
  arbitrary = Status <$> arbitrary <*> arbitrary <*> arbitrary


------------------------------------------------------------------------
data LanguageNodes = LanguageNodes { languageNodes___unknown__ :: [Int]}
    deriving (Show, Generic)
$(deriveJSON (unPrefix "languageNodes_") ''LanguageNodes)

------------------------------------------------------------------------
-- level: debug | dev  (fatal = critical)
data EventLevel = CRITICAL | FATAL | ERROR | WARNING | INFO | DEBUG
  deriving (Show, Generic, Enum, Bounded)

instance FromJSON EventLevel
instance ToJSON EventLevel

instance Arbitrary EventLevel where
  arbitrary = elements [minBound..maxBound]

instance ToSchema EventLevel where
  declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy

------------------------------------------------------------------------
data Event = Event { event_level   :: !EventLevel
                   , event_message :: !Text
                   , event_date    :: !UTCTime
            } deriving (Show, Generic)
$(deriveJSON (unPrefix "event_") ''Event)

instance Arbitrary Event where
  arbitrary = Event <$> arbitrary <*> arbitrary <*> arbitrary

instance ToSchema Event where
  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "event_")

------------------------------------------------------------------------
data Resource = Resource { resource_path    :: !(Maybe Text)
                         , resource_scraper :: !(Maybe Text)
                         , resource_query   :: !(Maybe Text)
                         , resource_events  :: !([Event])
                         , resource_status  :: !Status
                         , resource_date    :: !UTCTime
                         } deriving (Show, Generic)
$(deriveJSON (unPrefix "resource_") ''Resource)

instance Arbitrary Resource where
    arbitrary = Resource <$> arbitrary
                         <*> arbitrary
                         <*> arbitrary
                         <*> arbitrary
                         <*> arbitrary
                         <*> arbitrary

instance ToSchema Resource where
  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "resource_")

------------------------------------------------------------------------
-- | Then a Node can be either a Folder or a Corpus or a Document
data NodeType
  = NodeUser
  | NodeFolderPrivate
  | NodeFolderShared
  | NodeTeam
  | NodeFolderPublic
  | NodeFolder
  | NodeCorpus
  | NodeCorpusV3
  | NodeTexts
  | NodeDocument
  | NodeAnnuaire
  | NodeContact
  | NodeGraph
  | NodePhylo
  | NodeDashboard
  | NodeList
  | NodeModel
  | NodeListCooc
  -- Optional Nodes
  | Notes
  | Calc
  | NodeFrameVisio
  | NodeFrameNotebook
  | NodeFile
  deriving (Show, Read, Eq, Ord, Generic, Bounded, Enum)

instance GQLType NodeType
instance NFData NodeType where

-- /NOTE/ (adn) For backward-compatibility reasons, we keep the format for ToJSON/FromJSON similar
-- to what 'Show/Read' would generate, but we otherwise generate \"by hand\" the mapping between a
-- NodeType and its JSON representation, because this way we reduce the odds of /breaking the frontend/
-- in case we change the Show/Read instances in the future.
instance ToJSON NodeType where
  toJSON = JSON.String . \case
    NodeUser
      -> "NodeUser"
    NodeFolderPrivate
      -> "NodeFolderPrivate"
    NodeFolderShared
      -> "NodeFolderShared"
    NodeTeam
      -> "NodeTeam"
    NodeFolderPublic
      -> "NodeFolderPublic"
    NodeFolder
      -> "NodeFolder"
    NodeCorpus
      -> "NodeCorpus"
    NodeCorpusV3
      -> "NodeCorpusV3"
    NodeTexts
      -> "NodeTexts"
    NodeDocument
      -> "NodeDocument"
    NodeAnnuaire
      -> "NodeAnnuaire"
    NodeContact
      -> "NodeContact"
    NodeGraph
      -> "NodeGraph"
    NodePhylo
      -> "NodePhylo"
    NodeDashboard
      -> "NodeDashboard"
    NodeList
      -> "NodeList"
    NodeModel
      -> "NodeModel"
    NodeListCooc
      -> "NodeListCooc"
    Notes
      -> "Notes"
    Calc
      -> "Calc"
    NodeFrameVisio
      -> "NodeFrameVisio"
    NodeFrameNotebook
      -> "NodeFrameNotebook"
    NodeFile
      -> "NodeFile"

instance FromJSON NodeType where
  parseJSON = withText "NodeType" $ \t -> case t of
    "NodeUser"
      -> pure NodeUser
    "NodeFolderPrivate"
      -> pure NodeFolderPrivate
    "NodeFolderShared"
      -> pure NodeFolderShared
    "NodeTeam"
      -> pure NodeTeam
    "NodeFolderPublic"
      -> pure NodeFolderPublic
    "NodeFolder"
      -> pure NodeFolder
    "NodeCorpus"
      -> pure NodeCorpus
    "NodeCorpusV3"
      -> pure NodeCorpusV3
    "NodeTexts"
      -> pure NodeTexts
    "NodeDocument"
      -> pure NodeDocument
    "NodeAnnuaire"
      -> pure NodeAnnuaire
    "NodeContact"
      -> pure NodeContact
    "NodeGraph"
      -> pure NodeGraph
    "NodePhylo"
      -> pure NodePhylo
    "NodeDashboard"
      -> pure NodeDashboard
    "NodeList"
      -> pure NodeList
    "NodeModel"
      -> pure NodeModel
    "NodeListCooc"
      -> pure NodeListCooc
    "Notes"
      -> pure Notes
    "Calc"
      -> pure Calc
    "NodeFrameVisio"
      -> pure NodeFrameVisio
    "NodeFrameNotebook"
      -> pure NodeFrameNotebook
    "NodeFile"
      -> pure NodeFile
    unhandled
      -> typeMismatch "NodeType" (JSON.String unhandled)

-- | FIXME(adn) these instances could reuse the fromJSON/toJSON instances,
-- but for some reason this broke the frontend:
-- https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/277#note_10388
instance FromHttpApiData NodeType where
  parseUrlPiece = Right . read . unpack
instance ToHttpApiData NodeType where
  toUrlPiece = pack . show
instance ToParamSchema NodeType
instance ToSchema      NodeType
instance Arbitrary NodeType where
  arbitrary = arbitraryBoundedEnum
instance FromField NodeType where
  fromField = fromJSONField
instance ToField NodeType where
  toField = toJSONField


allNodeTypes :: [NodeType]
allNodeTypes = [minBound .. maxBound]

defaultName :: NodeType -> Text
defaultName NodeUser       = "User"
defaultName NodeContact    = "Contact"

defaultName NodeCorpus     = "Corpus"
defaultName NodeCorpusV3   = "Corpus"
defaultName NodeAnnuaire   = "Annuaire"

defaultName NodeDocument   = "Doc"
defaultName NodeTexts      = "Docs"
defaultName NodeList       = "Terms"
defaultName NodeListCooc   = "List"
defaultName NodeModel      = "Model"

defaultName NodeFolder        = "Folder"
defaultName NodeFolderPrivate = "Private"
defaultName NodeFolderShared  = "Share"
defaultName NodeTeam          = "Team"
defaultName NodeFolderPublic  = "Public"

defaultName NodeDashboard     = "Board"
defaultName NodeGraph         = "Graph"
defaultName NodePhylo         = "Phylo"

defaultName Notes    = "Note"
defaultName Calc     = "Calc"
defaultName NodeFrameVisio    = "Visio"
defaultName NodeFrameNotebook = "Code"

defaultName NodeFile          = "File"



------------------------------------------------------------------------
-- Instances
------------------------------------------------------------------------
instance ToSchema Status where
  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "status_")

------------------------------------------------------------------------
{-
instance FromField (NodeId, Text)
  where
    fromField = fromField'
-}
------------------------------------------------------------------------
instance DefaultFromField SqlTSVector (Maybe TSVector)
  where
    defaultFromField = fromPGSFromField

instance DefaultFromField SqlInt4 (Maybe NodeId)
  where
    defaultFromField = fromPGSFromField

instance DefaultFromField SqlInt4 NodeId
  where
    defaultFromField = fromPGSFromField

instance DefaultFromField (Nullable SqlInt4) NodeId
  where
    defaultFromField = fromPGSFromField

instance (DefaultFromField (Nullable O.SqlTimestamptz) UTCTime)
  where
    defaultFromField = fromPGSFromField

instance DefaultFromField SqlText (Maybe Hash)
  where
    defaultFromField = fromPGSFromField

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

context2node :: Context a -> Node a
context2node (Context ci ch ct cu cp cn cd chy) = Node ci ch ct cu cp cn cd chy

data NodePublishPolicy
  = -- | No edits are allowed (not even the ones from the owner)
    NPP_publish_no_edits_allowed
    -- | Edits after publishing are allowed only from the owner or the super user
  | NPP_publish_edits_only_owner_or_super
  deriving (Show, Read, Generic, Eq, Ord, Enum, Bounded)

instance NFData NodePublishPolicy where

instance HasDBid NodePublishPolicy where
  toDBid = \case
    NPP_publish_no_edits_allowed
      -> 0
    NPP_publish_edits_only_owner_or_super
      -> 1
  lookupDBid = \case
    0 -> Just NPP_publish_no_edits_allowed
    1 -> Just NPP_publish_edits_only_owner_or_super
    _ -> Nothing

instance ToSchema NodePublishPolicy where
  declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "NPP_")

instance ToJSON NodePublishPolicy where
  toJSON = \case
    NPP_publish_no_edits_allowed
      -> toJSON @T.Text "publish_no_edits_allowed"
    NPP_publish_edits_only_owner_or_super
      -> toJSON @T.Text "publish_edits_only_owner_or_super"

instance FromJSON NodePublishPolicy where
  parseJSON = JSON.withText "NodePublishPolicy" $ \case
    "publish_no_edits_allowed"
      -> pure NPP_publish_no_edits_allowed
    "publish_edits_only_owner_or_super"
      -> pure NPP_publish_edits_only_owner_or_super
    xs -> typeMismatch "NodePublishPolicy" (toJSON xs)
