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 = "Graph Title"
 258   let metadata = GraphMetadata title [maybe 0 identity $ _node_parentId nodeGraph]
 259                                      [ LegendField 1 "#FFF" "Cluster"
 260                                      , LegendField 2 "#FFF" "Cluster"
 261                                      ]
 262                          -- (map (\n -> LegendField n "#FFFFFF" (pack $ show n)) [1..10])
 263   let cId = maybe (panic "no parentId") identity $ _node_parentId nodeGraph
 264   lId <- defaultList cId
 265   myCooc <- getCoocByDocDev cId lId
 266   liftIO $ set graph_metadata (Just metadata)
 267         <$> cooc2graph myCooc
 268
 269         -- <$> maybe defaultGraph identity
 270         -- <$> readGraphFromJson "purescript-gargantext/dist/examples/imtNew.json"
 271   -- t <- textFlow (Mono EN) (Contexts contextText)
 272   -- liftIO $ liftIO $ pure $  maybe t identity maybeGraph
 273   -- TODO what do we get about the node? to replace contextText
 274
 275 instance HasNodeError ServantErr where
 276   _NodeError = prism' mk (const Nothing) -- $ panic "HasNodeError ServantErr: not a prism")
 277     where
 278       e = "NodeError: "
 279       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 280       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 281       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 282       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 283
 284       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 285       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 286       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 287       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 288       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 289       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 290       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 291
 292 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 293 instance HasTreeError ServantErr where
 294   _TreeError = prism' mk (const Nothing) -- $ panic "HasTreeError ServantErr: not a prism")
 295     where
 296       e = "TreeError: "
 297       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 298       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 299       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 300
 301 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 302 treeAPI :: NodeId -> GargServer TreeAPI
 303 treeAPI = treeDB
 304
 305 ------------------------------------------------------------------------
 306 -- | Check if the name is less than 255 char
 307 rename :: NodeId -> RenameNode -> Cmd err [Int]
 308 rename nId (RenameNode name) = U.update (U.Rename nId name)
 309
 310 getTable :: NodeId -> Maybe TabType
 311          -> Maybe Offset  -> Maybe Limit
 312          -> Maybe OrderBy -> Cmd err [FacetDoc]
 313 getTable cId ft o l order = case ft of
 314                                 (Just Docs)  -> runViewDocuments cId False o l order
 315                                 (Just Trash) -> runViewDocuments cId True  o l order
 316                                 _     -> panic "not implemented"
 317
 318 getPairing :: ContactId -> Maybe TabType
 319          -> Maybe Offset  -> Maybe Limit
 320          -> Maybe OrderBy -> Cmd err [FacetDoc]
 321 getPairing cId ft o l order = case ft of
 322                                 (Just Docs)  -> runViewAuthorsDoc cId False o l order
 323                                 (Just Trash) -> runViewAuthorsDoc cId True  o l order
 324                                 _     -> panic "not implemented"
 325
 326
 327 getChart :: NodeId -> Maybe UTCTime -> Maybe UTCTime
 328                    -> Cmd err [FacetChart]
 329 getChart _ _ _ = undefined -- TODO
 330
 331 postNode :: NodeId -> PostNode -> Cmd err [NodeId]
 332 postNode pId (PostNode name nt) = mk nt (Just pId) name
 333
 334 putNode :: NodeId -> Cmd err Int
 335 putNode = undefined -- TODO
 336
 337 query :: Monad m => Text -> m Text
 338 query s = pure s
 339
 340
 341 -- | Upload files
 342 -- TODO Is it possible to adapt the function according to iValue input ?
 343 --upload :: MultipartData -> Handler Text
 344 --upload multipartData = do
 345 --  liftIO $ do
 346 --    putStrLn "Inputs:"
 347 --    forM_ (inputs multipartData) $ \input ->
 348 --      putStrLn $ "  " <> show (iName input)
 349 --            <> " -> " <> show (iValue input)
 350 --
 351 --    forM_ (files multipartData) $ \file -> do
 352 --      content <- readFile (fdFilePath file)
 353 --      putStrLn $ "Content of " <> show (fdFileName file)
 354 --              <> " at " <> fdFilePath file
 355 --      putStrLn content
 356 --  pure (pack "Data loaded")
 357