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