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