src/Gargantext/Database/Admin/Types/Node.hs

   1 {-|
   2 Module      : Gargantext.Database.Types.Nodes
   3 Description : Main Types of Nodes in Database
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 -}
  11
  12 {-# OPTIONS_GHC -fno-warn-orphans #-}
  13
  14 {-# LANGUAGE BangPatterns               #-}
  15 {-# LANGUAGE TemplateHaskell            #-}
  16
  17 -- {-# LANGUAGE DuplicateRecordFields #-}
  18
  19 module Gargantext.Database.Admin.Types.Node
  20   where
  21
  22 import Database.PostgreSQL.Simple.ToRow (ToRow, toRow)
  23 import Codec.Serialise (Serialise())
  24 import Control.Monad (mzero)
  25 import Data.Aeson
  26 import Data.Aeson.TH (deriveJSON)
  27 import qualified Data.Csv as Csv
  28 import Data.Either
  29 import Data.Hashable (Hashable)
  30 import Data.Morpheus.Types (GQLType)
  31 import Data.Swagger
  32 import Data.Text (Text, unpack, pack)
  33 import Data.Time (UTCTime)
  34 import Database.PostgreSQL.Simple.FromField (FromField, fromField, fromJSONField)
  35 import Database.PostgreSQL.Simple.ToField (ToField, toField, toJSONField)
  36 import GHC.Generics (Generic)
  37 import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
  38 import Gargantext.Database.Schema.Context
  39 import Gargantext.Database.Schema.Node
  40 import Gargantext.Prelude
  41 import Gargantext.Prelude.Crypto.Hash (Hash)
  42 import Opaleye (DefaultFromField, defaultFromField, SqlInt4, SqlText, SqlTSVector, Nullable, fromPGSFromField)
  43 import Servant hiding (Context)
  44 import Test.QuickCheck (elements)
  45 import Test.QuickCheck.Arbitrary
  46 import Test.QuickCheck.Instances.Text ()
  47 import Test.QuickCheck.Instances.Time ()
  48 import Text.Read (read)
  49 import qualified Opaleye as O
  50
  51
  52
  53 type UserId = Int
  54 type MasterUserId = UserId
  55
  56 type NodeTypeId   = Int
  57 type NodeName     = Text
  58 type ContextName  = Text
  59
  60 type TSVector     = Text
  61 type ContextTitle  = Text
  62
  63
  64 ------------------------------------------------------------------------
  65 -- | NodePoly indicates that Node has a Polymorphism Type
  66 type Node    json = NodePoly    NodeId (Maybe Hash) NodeTypeId UserId (Maybe ParentId) NodeName UTCTime json
  67 type Context json = ContextPoly NodeId (Maybe Hash) NodeTypeId UserId (Maybe ParentId) ContextTitle UTCTime json
  68
  69 -- | NodeSearch (queries)
  70 -- type NodeSearch json   = NodePolySearch NodeId NodeTypeId UserId (Maybe ParentId) NodeName UTCTime json (Maybe TSVector)
  71
  72 ------------------------------------------------------------------------
  73
  74 instance (Typeable hyperdata, ToSchema hyperdata) =>
  75          ToSchema (NodePoly NodeId Hash NodeTypeId
  76                             (Maybe UserId)
  77                             ParentId NodeName
  78                             UTCTime hyperdata
  79                   ) where
  80   declareNamedSchema = wellNamedSchema "_node_"
  81
  82 instance (Typeable hyperdata, ToSchema hyperdata) =>
  83          ToSchema (NodePoly NodeId Hash NodeTypeId
  84                             UserId
  85                             (Maybe ParentId) NodeName
  86                             UTCTime hyperdata
  87                   ) where
  88   declareNamedSchema = wellNamedSchema "_node_"
  89
  90 instance (Typeable hyperdata, ToSchema hyperdata) =>
  91          ToSchema (NodePoly NodeId (Maybe Hash) NodeTypeId
  92                             UserId
  93                             (Maybe ParentId) NodeName
  94                             UTCTime hyperdata
  95                   ) where
  96   declareNamedSchema = wellNamedSchema "_node_"
  97
  98 instance (Typeable hyperdata, ToSchema hyperdata) =>
  99          ToSchema (NodePolySearch NodeId
 100                                   NodeTypeId
 101                                   (Maybe UserId)
 102                                   ParentId
 103                                   NodeName
 104                                   UTCTime
 105                                   hyperdata
 106                                   (Maybe TSVector)
 107                   ) where
 108   declareNamedSchema = wellNamedSchema "_ns_"
 109
 110 instance (Typeable hyperdata, ToSchema hyperdata) =>
 111          ToSchema (NodePolySearch NodeId
 112                                   NodeTypeId
 113                                   UserId
 114                                   (Maybe ParentId)
 115                                   NodeName
 116                                   UTCTime
 117                                   hyperdata
 118                                   (Maybe TSVector)
 119                   ) where
 120   declareNamedSchema = wellNamedSchema "_ns_"
 121
 122 instance (Arbitrary nodeId
 123          ,Arbitrary hashId
 124          ,Arbitrary toDBid
 125          ,Arbitrary userId
 126          ,Arbitrary nodeParentId
 127          , Arbitrary hyperdata
 128          ) => Arbitrary (NodePoly nodeId hashId toDBid userId nodeParentId
 129                                   NodeName UTCTime hyperdata) where
 130     --arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (arbitrary) (Just "")
 131     arbitrary = Node <$> arbitrary <*> arbitrary <*> arbitrary
 132                      <*> arbitrary <*> arbitrary <*> arbitrary
 133                      <*> arbitrary <*> arbitrary
 134
 135
 136
 137 instance (Arbitrary hyperdata
 138          ,Arbitrary nodeId
 139          ,Arbitrary toDBid
 140          ,Arbitrary userId
 141          ,Arbitrary nodeParentId
 142          ) => Arbitrary (NodePolySearch nodeId
 143                                         toDBid
 144                                         userId
 145                                         nodeParentId
 146                                         NodeName
 147                                         UTCTime
 148                                         hyperdata
 149                                         (Maybe TSVector)
 150                         ) where
 151     --arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (arbitrary) (Just "")
 152     arbitrary = NodeSearch <$> arbitrary
 153                            <*> arbitrary
 154                            <*> arbitrary
 155                            <*> arbitrary
 156                            <*> arbitrary
 157                            <*> arbitrary
 158                            <*> arbitrary
 159                            <*> arbitrary
 160
 161
 162 instance (Arbitrary contextId
 163          ,Arbitrary hashId
 164          ,Arbitrary toDBid
 165          ,Arbitrary userId
 166          ,Arbitrary contextParentId
 167          , Arbitrary hyperdata
 168          ) => Arbitrary (ContextPoly contextId hashId toDBid userId contextParentId
 169                                   ContextName UTCTime hyperdata) where
 170     --arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (arbitrary) (Just "")
 171     arbitrary = Context <$> arbitrary <*> arbitrary <*> arbitrary
 172                         <*> arbitrary <*> arbitrary <*> arbitrary
 173                         <*> arbitrary <*> arbitrary
 174
 175 instance (Arbitrary hyperdata
 176          ,Arbitrary contextId
 177          ,Arbitrary toDBid
 178          ,Arbitrary userId
 179          ,Arbitrary contextParentId
 180          ) => Arbitrary (ContextPolySearch contextId
 181                                         toDBid
 182                                         userId
 183                                         contextParentId
 184                                         ContextName
 185                                         UTCTime
 186                                         hyperdata
 187                                         (Maybe TSVector)
 188                         ) where
 189     --arbitrary = Node 1 1 (Just 1) 1 "name" (jour 2018 01 01) (arbitrary) (Just "")
 190     arbitrary = ContextSearch <$> arbitrary
 191                               <*> arbitrary
 192                               <*> arbitrary
 193                               <*> arbitrary
 194                               <*> arbitrary
 195                               <*> arbitrary
 196                               <*> arbitrary
 197                               <*> arbitrary
 198
 199
 200
 201
 202 ------------------------------------------------------------------------
 203 pgNodeId :: NodeId -> O.Column O.SqlInt4
 204 pgNodeId = O.sqlInt4 . id2int
 205   where
 206     id2int :: NodeId -> Int
 207     id2int (NodeId n) = n
 208
 209 pgContextId :: ContextId -> O.Column O.SqlInt4
 210 pgContextId = pgNodeId
 211
 212 ------------------------------------------------------------------------
 213 newtype NodeId = NodeId Int
 214   deriving (Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField)
 215 instance GQLType NodeId
 216 instance Show NodeId where
 217   show (NodeId n) = "nodeId-" <> show n
 218 instance Serialise NodeId
 219 instance ToField NodeId where
 220   toField (NodeId n) = toField n
 221 instance ToRow NodeId where
 222   toRow (NodeId i) = [toField i]
 223
 224 instance FromField NodeId where
 225   fromField field mdata = do
 226     n <- fromField field mdata
 227     if (n :: Int) > 0
 228        then return $ NodeId n
 229        else mzero
 230 instance ToSchema NodeId
 231
 232 -- TODO make another type
 233 type ContextId = NodeId
 234
 235 newtype NodeContextId = NodeContextId Int
 236   deriving (Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON, Hashable, Csv.ToField)
 237
 238
 239 --instance Csv.ToField NodeId where
 240 --  toField (NodeId nodeId) = Csv.toField nodeId
 241
 242 unNodeId :: NodeId -> Int
 243 unNodeId (NodeId n) = n
 244
 245 ------------------------------------------------------------------------
 246 ------------------------------------------------------------------------
 247 instance FromHttpApiData NodeId where
 248   parseUrlPiece n = pure $ NodeId $ (read . cs) n
 249 instance ToHttpApiData NodeId where
 250   toUrlPiece (NodeId n) = toUrlPiece n
 251 instance ToParamSchema NodeId
 252 instance Arbitrary NodeId where
 253   arbitrary = NodeId <$> arbitrary
 254
 255 type ParentId    = NodeId
 256 type CorpusId    = NodeId
 257 type CommunityId = NodeId
 258 type ListId      = NodeId
 259 type DocumentId  = NodeId
 260 type DocId       = NodeId
 261 type RootId      = NodeId
 262 type MasterCorpusId = CorpusId
 263 type UserCorpusId   = CorpusId
 264
 265 type GraphId  = NodeId
 266 type PhyloId  = NodeId
 267 type AnnuaireId = NodeId
 268 type ContactId  = NodeId
 269
 270 ------------------------------------------------------------------------
 271 data Status  = Status { status_failed    :: !Int
 272                       , status_succeeded :: !Int
 273                       , status_remaining :: !Int
 274                       } deriving (Show, Generic)
 275 $(deriveJSON (unPrefix "status_") ''Status)
 276
 277 instance Arbitrary Status where
 278   arbitrary = Status <$> arbitrary <*> arbitrary <*> arbitrary
 279
 280
 281 ------------------------------------------------------------------------
 282 data LanguageNodes = LanguageNodes { languageNodes___unknown__ :: [Int]}
 283     deriving (Show, Generic)
 284 $(deriveJSON (unPrefix "languageNodes_") ''LanguageNodes)
 285
 286 ------------------------------------------------------------------------
 287 -- level: debug | dev  (fatal = critical)
 288 data EventLevel = CRITICAL | FATAL | ERROR | WARNING | INFO | DEBUG
 289   deriving (Show, Generic, Enum, Bounded)
 290
 291 instance FromJSON EventLevel
 292 instance ToJSON EventLevel
 293
 294 instance Arbitrary EventLevel where
 295   arbitrary = elements [minBound..maxBound]
 296
 297 instance ToSchema EventLevel where
 298   declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
 299
 300 ------------------------------------------------------------------------
 301 data Event = Event { event_level   :: !EventLevel
 302                    , event_message :: !Text
 303                    , event_date    :: !UTCTime
 304             } deriving (Show, Generic)
 305 $(deriveJSON (unPrefix "event_") ''Event)
 306
 307 instance Arbitrary Event where
 308   arbitrary = Event <$> arbitrary <*> arbitrary <*> arbitrary
 309
 310 instance ToSchema Event where
 311   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "event_")
 312
 313 ------------------------------------------------------------------------
 314 data Resource = Resource { resource_path    :: !(Maybe Text)
 315                          , resource_scraper :: !(Maybe Text)
 316                          , resource_query   :: !(Maybe Text)
 317                          , resource_events  :: !([Event])
 318                          , resource_status  :: !Status
 319                          , resource_date    :: !UTCTime
 320                          } deriving (Show, Generic)
 321 $(deriveJSON (unPrefix "resource_") ''Resource)
 322
 323 instance Arbitrary Resource where
 324     arbitrary = Resource <$> arbitrary
 325                          <*> arbitrary
 326                          <*> arbitrary
 327                          <*> arbitrary
 328                          <*> arbitrary
 329                          <*> arbitrary
 330
 331 instance ToSchema Resource where
 332   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "resource_")
 333
 334 ------------------------------------------------------------------------
 335 -- | Then a Node can be either a Folder or a Corpus or a Document
 336 data NodeType = NodeUser
 337               | NodeFolderPrivate
 338               | NodeFolderShared | NodeTeam
 339               | NodeFolderPublic
 340               | NodeFolder
 341
 342               -- | NodeAnalysis | NodeCommunity
 343
 344               | NodeCorpus     | NodeCorpusV3 | NodeTexts | NodeDocument
 345               | NodeAnnuaire   | NodeContact
 346               | NodeGraph      | NodePhylo
 347               | NodeDashboard  -- | NodeChart    | NodeNoteBook
 348               | NodeList       | NodeModel
 349               | NodeListCooc
 350
 351 {-
 352               -- | Metrics
 353               -- | NodeOccurrences
 354               -- | Classification
 355 -}
 356
 357               -- Optional Nodes
 358               | Notes | Calc | NodeFrameVisio | NodeFrameNotebook
 359               | NodeFile
 360
 361   deriving (Show, Read, Eq, Generic, Bounded, Enum)
 362
 363
 364 instance GQLType NodeType
 365 instance FromJSON NodeType
 366 instance ToJSON NodeType
 367 instance FromHttpApiData NodeType where
 368   parseUrlPiece = Right . read . unpack
 369 instance ToHttpApiData NodeType where
 370   toUrlPiece = pack . show
 371 instance ToParamSchema NodeType
 372 instance ToSchema      NodeType
 373 instance Arbitrary NodeType where
 374   arbitrary = elements allNodeTypes
 375 instance FromField NodeType where
 376   fromField = fromJSONField
 377 instance ToField NodeType where
 378   toField = toJSONField
 379
 380
 381 allNodeTypes :: [NodeType]
 382 allNodeTypes = [minBound ..]
 383
 384 defaultName :: NodeType -> Text
 385 defaultName NodeUser       = "User"
 386 defaultName NodeContact    = "Contact"
 387
 388 defaultName NodeCorpus     = "Corpus"
 389 defaultName NodeCorpusV3   = "Corpus"
 390 defaultName NodeAnnuaire   = "Annuaire"
 391
 392 defaultName NodeDocument   = "Doc"
 393 defaultName NodeTexts      = "Docs"
 394 defaultName NodeList       = "Terms"
 395 defaultName NodeListCooc   = "List"
 396 defaultName NodeModel      = "Model"
 397
 398 defaultName NodeFolder        = "Folder"
 399 defaultName NodeFolderPrivate = "Private"
 400 defaultName NodeFolderShared  = "Share"
 401 defaultName NodeTeam          = "Team"
 402 defaultName NodeFolderPublic  = "Public"
 403
 404 defaultName NodeDashboard     = "Board"
 405 defaultName NodeGraph         = "Graph"
 406 defaultName NodePhylo         = "Phylo"
 407
 408 defaultName Notes    = "Note"
 409 defaultName Calc     = "Calc"
 410 defaultName NodeFrameVisio    = "Visio"
 411 defaultName NodeFrameNotebook = "Code"
 412
 413 defaultName NodeFile          = "File"
 414
 415
 416
 417 ------------------------------------------------------------------------
 418 -- Instances
 419 ------------------------------------------------------------------------
 420 instance ToSchema Status where
 421   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "status_")
 422
 423 ------------------------------------------------------------------------
 424 {-
 425 instance FromField (NodeId, Text)
 426   where
 427     fromField = fromField'
 428 -}
 429 ------------------------------------------------------------------------
 430 instance DefaultFromField SqlTSVector (Maybe TSVector)
 431   where
 432     defaultFromField = fromPGSFromField
 433
 434 instance DefaultFromField SqlInt4 (Maybe NodeId)
 435   where
 436     defaultFromField = fromPGSFromField
 437
 438 instance DefaultFromField SqlInt4 NodeId
 439   where
 440     defaultFromField = fromPGSFromField
 441
 442 instance DefaultFromField (Nullable SqlInt4) NodeId
 443   where
 444     defaultFromField = fromPGSFromField
 445
 446 instance (DefaultFromField (Nullable O.SqlTimestamptz) UTCTime)
 447   where
 448     defaultFromField = fromPGSFromField
 449
 450 instance DefaultFromField SqlText (Maybe Hash)
 451   where
 452     defaultFromField = fromPGSFromField
 453
 454 ---------------------------------------------------------------------
 455
 456 context2node :: Context a -> Node a
 457 context2node (Context ci ch ct cu cp cn cd chy) = Node ci ch ct cu cp cn cd chy