src/Gargantext/API/Node.hs

   1 {-|
   2 Module      : Gargantext.API.Node
   3 Description : Server API
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Node API
  11 -}
  12
  13 {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}
  14
  15 {-# LANGUAGE DataKinds          #-}
  16 {-# LANGUAGE DeriveGeneric      #-}
  17 {-# LANGUAGE FlexibleContexts   #-}
  18 {-# LANGUAGE NoImplicitPrelude  #-}
  19 {-# LANGUAGE OverloadedStrings  #-}
  20 {-# LANGUAGE RankNTypes         #-}
  21 {-# LANGUAGE TemplateHaskell    #-}
  22 {-# LANGUAGE TypeOperators      #-}
  23
  24 -------------------------------------------------------------------
  25 module Gargantext.API.Node
  26   ( module Gargantext.API.Node
  27   , HyperdataAny(..)
  28   , HyperdataAnnuaire(..)
  29   , HyperdataCorpus(..)
  30   , HyperdataResource(..)
  31   , HyperdataUser(..)
  32   , HyperdataDocument(..)
  33   , HyperdataDocumentV3(..)
  34   ) where
  35 -------------------------------------------------------------------
  36 import Control.Lens (prism', set)
  37 import Control.Monad.IO.Class (liftIO)
  38 import Control.Monad ((>>))
  39 --import System.IO (putStrLn, readFile)
  40
  41 import Data.Aeson (FromJSON, ToJSON)
  42 import Data.Text (Text())
  43 import Data.Swagger
  44 import Data.Time (UTCTime)
  45
  46 import GHC.Generics (Generic)
  47 import Servant
  48
  49 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams)
  50 import Gargantext.Prelude
  51 import Gargantext.Database.Types.Node
  52 import Gargantext.Database.Utils -- (Cmd, CmdM)
  53 import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, deleteNode, deleteNodes, mk, JSONB, NodeError(..), HasNodeError(..))
  54 import Gargantext.Database.Node.Children (getChildren)
  55 import qualified Gargantext.Database.Node.Update as U (update, Update(..))
  56 import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),FacetChart,runViewAuthorsDoc)
  57 import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
  58 import Gargantext.Database.Metrics.Count (getCoocByDocDev)
  59 import Gargantext.Database.Schema.Node (defaultList)
  60 import Gargantext.Database.Schema.NodeNode (nodesToFavorite, nodesToTrash)
  61 import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
  62
  63 -- Graph
  64 import Gargantext.Text.Flow (cooc2graph)
  65 import Gargantext.Viz.Graph hiding (Node)-- (Graph(_graph_metadata),LegendField(..), GraphMetadata(..),readGraphFromJson,defaultGraph)
  66 -- import Gargantext.Core (Lang(..))
  67 import Gargantext.Core.Types (Offset, Limit)
  68 import Gargantext.Core.Types.Main (Tree, NodeTree)
  69 import Gargantext.Database.Types.Node (CorpusId, ContactId)
  70 -- import Gargantext.Text.Terms (TermType(..))
  71
  72 import Test.QuickCheck (elements)
  73 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  74
  75 type GargServer api = forall env m. CmdM env ServantErr m => ServerT api m
  76
  77 -------------------------------------------------------------------
  78 -- | TODO : access by admin only
  79 type NodesAPI  = Delete '[JSON] Int
  80
  81 -- | Delete Nodes
  82 -- Be careful: really delete nodes
  83 -- Access by admin only
  84 nodesAPI :: [NodeId] -> GargServer NodesAPI
  85 nodesAPI ids = deleteNodes ids
  86
  87 ------------------------------------------------------------------------
  88 -- | TODO: access by admin only
  89 -- To manager the Users roots
  90 type Roots =  Get    '[JSON] [NodeAny]
  91          :<|> Put    '[JSON] Int -- TODO
  92
  93 -- | TODO: access by admin only
  94 roots :: GargServer Roots
  95 roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
  96    :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
  97
  98 -------------------------------------------------------------------
  99 -- | Node API Types management
 100 -- TODO : access by users
 101 type NodeAPI a = Get '[JSON] (Node a)
 102              :<|> "rename" :> RenameApi
 103              :<|> PostNodeApi
 104              :<|> Put    '[JSON] Int
 105              :<|> Delete '[JSON] Int
 106              :<|> "children"  :> ChildrenApi a
 107
 108              -- TODO gather it
 109              :<|> "table"     :> TableApi
 110              :<|> "list"      :> TableNgramsApi
 111              :<|> "listGet"   :> TableNgramsApiGet
 112              :<|> "pairing"   :> PairingApi
 113
 114              :<|> "chart"     :> ChartApi
 115              :<|> "favorites" :> FavApi
 116              :<|> "documents" :> DocsApi
 117              :<|> "search":> Summary "Node Search"
 118                         :> ReqBody '[JSON] SearchInQuery
 119                         :> QueryParam "offset" Int
 120                         :> QueryParam "limit"  Int
 121                         :> QueryParam "order"  OrderBy
 122                         :> SearchAPI
 123
 124 type RenameApi = Summary " Rename Node"
 125                :> ReqBody '[JSON] RenameNode
 126                :> Put     '[JSON] [Int]
 127
 128 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 129                  :> ReqBody '[JSON] PostNode
 130                  :> Post    '[JSON] [NodeId]
 131
 132 type ChildrenApi a = Summary " Summary children"
 133                  :> QueryParam "type"   NodeType
 134                  :> QueryParam "offset" Int
 135                  :> QueryParam "limit"  Int
 136                  :> Get '[JSON] [Node a]
 137 ------------------------------------------------------------------------
 138 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 139 nodeAPI :: JSONB a => proxy a -> NodeId -> GargServer (NodeAPI a)
 140 nodeAPI p id =  getNode     id p
 141            :<|> rename      id
 142            :<|> postNode    id
 143            :<|> putNode     id
 144            :<|> deleteNode  id
 145            :<|> getChildren id p
 146
 147            -- TODO gather it
 148            :<|> getTable         id
 149            :<|> tableNgramsPatch id
 150            :<|> getTableNgrams   id
 151            :<|> getPairing       id
 152
 153            :<|> getChart id
 154            :<|> favApi   id
 155            :<|> delDocs  id
 156            :<|> searchIn id
 157            -- Annuaire
 158            -- :<|> upload
 159            -- :<|> query
 160 ------------------------------------------------------------------------
 161 data RenameNode = RenameNode { r_name :: Text }
 162   deriving (Generic)
 163
 164 instance FromJSON  RenameNode
 165 instance ToJSON    RenameNode
 166 instance ToSchema  RenameNode
 167 instance Arbitrary RenameNode where
 168   arbitrary = elements [RenameNode "test"]
 169 ------------------------------------------------------------------------
 170 data PostNode = PostNode { pn_name :: Text
 171                          , pn_typename :: NodeType}
 172   deriving (Generic)
 173
 174 instance FromJSON  PostNode
 175 instance ToJSON    PostNode
 176 instance ToSchema  PostNode
 177 instance Arbitrary PostNode where
 178   arbitrary = elements [PostNode "Node test" NodeCorpus]
 179
 180 ------------------------------------------------------------------------
 181 type DocsApi = Summary "Docs : Move to trash"
 182              :> ReqBody '[JSON] Documents
 183              :> Delete  '[JSON] [Int]
 184
 185 data Documents = Documents { documents :: [NodeId]}
 186   deriving (Generic)
 187
 188 instance FromJSON  Documents
 189 instance ToJSON    Documents
 190 instance ToSchema  Documents
 191
 192 delDocs :: CorpusId -> Documents -> Cmd err [Int]
 193 delDocs cId ds = nodesToTrash $ map (\n -> (cId, n, True)) $ documents ds
 194
 195 ------------------------------------------------------------------------
 196 type FavApi =  Summary " Favorites label"
 197             :> ReqBody '[JSON] Favorites
 198             :> Put     '[JSON] [Int]
 199           :<|> Summary " Favorites unlabel"
 200             :> ReqBody '[JSON] Favorites
 201             :> Delete  '[JSON] [Int]
 202
 203 data Favorites = Favorites { favorites :: [NodeId]}
 204   deriving (Generic)
 205
 206 instance FromJSON  Favorites
 207 instance ToJSON    Favorites
 208 instance ToSchema  Favorites
 209
 210 putFav :: CorpusId -> Favorites -> Cmd err [Int]
 211 putFav cId fs = nodesToFavorite $ map (\n -> (cId, n, True)) $ favorites fs
 212
 213 delFav :: CorpusId -> Favorites -> Cmd err [Int]
 214 delFav cId fs = nodesToFavorite $ map (\n -> (cId, n, False)) $ favorites fs
 215
 216 favApi :: CorpusId -> GargServer FavApi
 217 favApi cId = putFav cId :<|> delFav cId
 218
 219 ------------------------------------------------------------------------
 220 type TableApi = Summary " Table API"
 221               :> QueryParam "view"   TabType
 222               :> QueryParam "offset" Int
 223               :> QueryParam "limit"  Int
 224               :> QueryParam "order"  OrderBy
 225               :> Get '[JSON] [FacetDoc]
 226
 227 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 228 type PairingApi = Summary " Pairing API"
 229               :> QueryParam "view"   TabType -- TODO change TabType -> DocType (CorpusId for pairing)
 230               :> QueryParam "offset" Int
 231               :> QueryParam "limit"  Int
 232               :> QueryParam "order"  OrderBy
 233               :> Get '[JSON] [FacetDoc]
 234
 235 ------------------------------------------------------------------------
 236 type ChartApi = Summary " Chart API"
 237               :> QueryParam "from" UTCTime
 238               :> QueryParam "to"   UTCTime
 239               :> Get '[JSON] [FacetChart]
 240
 241                 -- Depending on the Type of the Node, we could post
 242                 -- New documents for a corpus
 243                 -- New map list terms
 244              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 245
 246                 -- To launch a query and update the corpus
 247              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 248
 249 ------------------------------------------------------------------------
 250 type GraphAPI   = Get '[JSON] Graph
 251
 252 graphAPI :: NodeId -> GargServer GraphAPI
 253 graphAPI nId = do
 254
 255   nodeGraph <- getNode nId HyperdataGraph
 256
 257   let title = "IMT - Scientific publications - 1982-2017 - English"
 258   let metadata = GraphMetadata title [maybe 0 identity $ _node_parentId nodeGraph]
 259                                      [ LegendField 6 "#FFF" "Data processing"
 260                                      , LegendField 7 "#FFF" "Networks"
 261                                      , LegendField 1 "#FFF" "Material science"
 262                                      , LegendField 5 "#FFF" "Energy / Environment"
 263                                      ]
 264                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 265   let cId = maybe (panic "no parentId") identity $ _node_parentId nodeGraph
 266   lId <- defaultList cId
 267   myCooc <- getCoocByDocDev cId lId
 268   liftIO $ set graph_metadata (Just metadata)
 269         <$> cooc2graph myCooc
 270
 271         -- <$> maybe defaultGraph identity
 272         -- <$> readGraphFromJson "purescript-gargantext/dist/examples/imtNew.json"
 273   -- t <- textFlow (Mono EN) (Contexts contextText)
 274   -- liftIO $ liftIO $ pure $  maybe t identity maybeGraph
 275   -- TODO what do we get about the node? to replace contextText
 276
 277 instance HasNodeError ServantErr where
 278   _NodeError = prism' mk (const Nothing) -- $ panic "HasNodeError ServantErr: not a prism")
 279     where
 280       e = "NodeError: "
 281       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 282       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 283       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 284       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 285
 286       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 287       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 288       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 289       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 290       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 291       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 292       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 293
 294 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 295 instance HasTreeError ServantErr where
 296   _TreeError = prism' mk (const Nothing) -- $ panic "HasTreeError ServantErr: not a prism")
 297     where
 298       e = "TreeError: "
 299       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 300       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 301       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 302
 303 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 304 treeAPI :: NodeId -> GargServer TreeAPI
 305 treeAPI = treeDB
 306
 307 ------------------------------------------------------------------------
 308 -- | Check if the name is less than 255 char
 309 rename :: NodeId -> RenameNode -> Cmd err [Int]
 310 rename nId (RenameNode name) = U.update (U.Rename nId name)
 311
 312 getTable :: NodeId -> Maybe TabType
 313          -> Maybe Offset  -> Maybe Limit
 314          -> Maybe OrderBy -> Cmd err [FacetDoc]
 315 getTable cId ft o l order = case ft of
 316                                 (Just Docs)  -> runViewDocuments cId False o l order
 317                                 (Just Trash) -> runViewDocuments cId True  o l order
 318                                 _     -> panic "not implemented"
 319
 320 getPairing :: ContactId -> Maybe TabType
 321          -> Maybe Offset  -> Maybe Limit
 322          -> Maybe OrderBy -> Cmd err [FacetDoc]
 323 getPairing cId ft o l order = case ft of
 324                                 (Just Docs)  -> runViewAuthorsDoc cId False o l order
 325                                 (Just Trash) -> runViewAuthorsDoc cId True  o l order
 326                                 _     -> panic "not implemented"
 327
 328
 329 getChart :: NodeId -> Maybe UTCTime -> Maybe UTCTime
 330                    -> Cmd err [FacetChart]
 331 getChart _ _ _ = undefined -- TODO
 332
 333 postNode :: NodeId -> PostNode -> Cmd err [NodeId]
 334 postNode pId (PostNode name nt) = mk nt (Just pId) name
 335
 336 putNode :: NodeId -> Cmd err Int
 337 putNode = undefined -- TODO
 338
 339 query :: Monad m => Text -> m Text
 340 query s = pure s
 341
 342
 343 -- | Upload files
 344 -- TODO Is it possible to adapt the function according to iValue input ?
 345 --upload :: MultipartData -> Handler Text
 346 --upload multipartData = do
 347 --  liftIO $ do
 348 --    putStrLn "Inputs:"
 349 --    forM_ (inputs multipartData) $ \input ->
 350 --      putStrLn $ "  " <> show (iName input)
 351 --            <> " -> " <> show (iValue input)
 352 --
 353 --    forM_ (files multipartData) $ \file -> do
 354 --      content <- readFile (fdFilePath file)
 355 --      putStrLn $ "Content of " <> show (fdFileName file)
 356 --              <> " at " <> fdFilePath file
 357 --      putStrLn content
 358 --  pure (pack "Data loaded")
 359