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
  11 -- TODO-ACCESS: CanGetNode
  12 -- TODO-EVENTS: No events as this is a read only query.
  13 Node API
  14
  15 -------------------------------------------------------------------
  16 -- TODO-ACCESS: access by admin only.
  17 --              At first let's just have an isAdmin check.
  18 --              Later: check userId CanDeleteNodes Nothing
  19 -- TODO-EVENTS: DeletedNodes [NodeId]
  20 --              {"tag": "DeletedNodes", "nodes": [Int*]}
  21
  22
  23 -}
  24
  25 {-# OPTIONS_GHC -fno-warn-orphans #-}
  26
  27 {-# LANGUAGE DataKinds            #-}
  28 {-# LANGUAGE DeriveGeneric        #-}
  29 {-# LANGUAGE FlexibleContexts     #-}
  30 {-# LANGUAGE FlexibleInstances    #-}
  31 {-# LANGUAGE NoImplicitPrelude    #-}
  32 {-# LANGUAGE OverloadedStrings    #-}
  33 {-# LANGUAGE RankNTypes           #-}
  34 {-# LANGUAGE ScopedTypeVariables  #-}
  35 {-# LANGUAGE TemplateHaskell      #-}
  36 {-# LANGUAGE TypeOperators        #-}
  37
  38 module Gargantext.API.Node
  39   where
  40
  41 import Control.Lens (prism', (.~), (?~))
  42 import Control.Monad ((>>), forM)
  43 import Control.Monad.IO.Class (liftIO)
  44 import Data.Aeson (FromJSON, ToJSON)
  45 import Data.Maybe
  46 import Data.Monoid (mempty)
  47 import Data.Swagger
  48 import Data.Text (Text())
  49 import Data.Time (UTCTime)
  50 import GHC.Generics (Generic)
  51 import Gargantext.API.Metrics
  52 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR, TODO)
  53 import Gargantext.API.Ngrams.NTree (MyTree)
  54 import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
  55 import Gargantext.API.Types
  56 import Gargantext.Core.Types (Offset, Limit)
  57 import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
  58 import Gargantext.Database.Config (nodeTypeId)
  59 import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),runViewAuthorsDoc)
  60 import Gargantext.Database.Node.Children (getChildren)
  61 import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, getNode', deleteNode, deleteNodes, mkNodeWithParent, JSONB, NodeError(..), HasNodeError(..))
  62 import Gargantext.Database.Schema.NodeNode (nodesToFavorite, nodesToTrash)
  63 import Gargantext.Database.Tree (treeDB, HasTreeError(..), TreeError(..))
  64 import Gargantext.Database.Types.Node
  65 import Gargantext.Database.Utils -- (Cmd, CmdM)
  66 import Gargantext.Prelude
  67 import Gargantext.Prelude.Utils (hash)
  68 import Gargantext.Text.Metrics (Scored(..))
  69 import Gargantext.Viz.Chart
  70 import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
  71 import Servant
  72 import Servant.Multipart
  73 import Servant.Swagger (HasSwagger(toSwagger))
  74 import Servant.Swagger.Internal
  75 import Test.QuickCheck (elements)
  76 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  77 import qualified Data.Map as Map
  78 import qualified Gargantext.Database.Metrics as Metrics
  79 import qualified Gargantext.Database.Node.Update as U (update, Update(..))
  80
  81 {-
  82 import qualified Gargantext.Text.List.Learn as Learn
  83 import qualified Data.Vector as Vec
  84 --}
  85
  86
  87 type NodesAPI  = Delete '[JSON] Int
  88
  89 -- | Delete Nodes
  90 -- Be careful: really delete nodes
  91 -- Access by admin only
  92 nodesAPI :: [NodeId] -> GargServer NodesAPI
  93 nodesAPI ids = deleteNodes ids
  94
  95 ------------------------------------------------------------------------
  96 -- | TODO-ACCESS: access by admin only.
  97 -- At first let's just have an isAdmin check.
  98 -- Later: CanAccessAnyNode or (CanGetAnyNode, CanPutAnyNode)
  99 -- To manage the Users roots
 100 -- TODO-EVENTS:
 101 --   PutNode ?
 102 -- TODO needs design discussion.
 103 type Roots =  Get    '[JSON] [NodeAny]
 104          :<|> Put    '[JSON] Int -- TODO
 105
 106 -- | TODO: access by admin only
 107 roots :: GargServer Roots
 108 roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
 109    :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
 110
 111 -------------------------------------------------------------------
 112 -- | Node API Types management
 113 -- TODO-ACCESS : access by users
 114 -- No ownership check is needed if we strictly follow the capability model.
 115 --
 116 -- CanGetNode (Node, Children, TableApi, TableNgramsApiGet, PairingApi, ChartApi,
 117 --             SearchAPI)
 118 -- CanRenameNode (or part of CanEditNode?)
 119 -- CanCreateChildren (PostNodeApi)
 120 -- CanEditNode / CanPutNode TODO not implemented yet
 121 -- CanDeleteNode
 122 -- CanPatch (TableNgramsApi)
 123 -- CanFavorite
 124 -- CanMoveToTrash
 125 type NodeAPI a = Get '[JSON] (Node a)
 126              :<|> "rename" :> RenameApi
 127              :<|> PostNodeApi -- TODO move to children POST
 128              :<|> Put    '[JSON] Int
 129              :<|> Delete '[JSON] Int
 130              :<|> "children"  :> ChildrenApi a
 131
 132              -- TODO gather it
 133              :<|> "table"     :> TableApi
 134              :<|> "ngrams"    :> TableNgramsApi
 135              :<|> "pairing"   :> PairingApi
 136
 137              :<|> "favorites" :> FavApi
 138              :<|> "documents" :> DocsApi
 139              :<|> "search":> Summary "Node Search"
 140                         :> ReqBody '[JSON] SearchInQuery
 141                         :> QueryParam "offset" Int
 142                         :> QueryParam "limit"  Int
 143                         :> QueryParam "order"  OrderBy
 144                         :> SearchAPI
 145
 146              -- VIZ
 147              :<|> "metrics" :> MetricsAPI
 148              :<|> "chart"     :> ChartApi
 149              :<|> "pie"       :> PieApi
 150              :<|> "tree"      :> TreeApi
 151              :<|> "phylo"     :> PhyloAPI
 152              :<|> "upload"    :> UploadAPI
 153
 154 -- TODO-ACCESS: check userId CanRenameNode nodeId
 155 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
 156 type RenameApi = Summary " Rename Node"
 157                :> ReqBody '[JSON] RenameNode
 158                :> Put     '[JSON] [Int]
 159
 160 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 161                  :> ReqBody '[JSON] PostNode
 162                  :> Post    '[JSON] [NodeId]
 163
 164 type ChildrenApi a = Summary " Summary children"
 165                  :> QueryParam "type"   NodeType
 166                  :> QueryParam "offset" Int
 167                  :> QueryParam "limit"  Int
 168                  :> Get '[JSON] [Node a]
 169 ------------------------------------------------------------------------
 170 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 171 nodeAPI :: JSONB a => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
 172 nodeAPI p uId id
 173              =  getNode     id p
 174            :<|> rename      id
 175            :<|> postNode    uId id
 176            :<|> putNode     id
 177            :<|> deleteNodeApi  id
 178            :<|> getChildren id p
 179
 180            -- TODO gather it
 181            :<|> getTable         id
 182            :<|> apiNgramsTableCorpus id
 183            :<|> getPairing       id
 184            -- :<|> getTableNgramsDoc id
 185
 186            :<|> favApi   id
 187            :<|> delDocs  id
 188            :<|> searchIn id
 189
 190            :<|> getMetrics id
 191            :<|> getChart id
 192            :<|> getPie   id
 193            :<|> getTree  id
 194            :<|> phyloAPI id
 195            :<|> postUpload id
 196   where
 197     deleteNodeApi id' = do
 198       node <- getNode' id'
 199       if _node_typename node == nodeTypeId NodeUser
 200          then panic "not allowed"  -- TODO add proper Right Management Type
 201          else deleteNode id'
 202
 203            -- Annuaire
 204            -- :<|> query
 205
 206
 207 ------------------------------------------------------------------------
 208 data RenameNode = RenameNode { r_name :: Text }
 209   deriving (Generic)
 210
 211 instance FromJSON  RenameNode
 212 instance ToJSON    RenameNode
 213 instance ToSchema  RenameNode
 214 instance Arbitrary RenameNode where
 215   arbitrary = elements [RenameNode "test"]
 216 ------------------------------------------------------------------------
 217 data PostNode = PostNode { pn_name :: Text
 218                          , pn_typename :: NodeType}
 219   deriving (Generic)
 220
 221 instance FromJSON  PostNode
 222 instance ToJSON    PostNode
 223 instance ToSchema  PostNode
 224 instance Arbitrary PostNode where
 225   arbitrary = elements [PostNode "Node test" NodeCorpus]
 226
 227 ------------------------------------------------------------------------
 228 type DocsApi = Summary "Docs : Move to trash"
 229              :> ReqBody '[JSON] Documents
 230              :> Delete  '[JSON] [Int]
 231
 232 data Documents = Documents { documents :: [NodeId]}
 233   deriving (Generic)
 234
 235 instance FromJSON  Documents
 236 instance ToJSON    Documents
 237 instance ToSchema  Documents
 238
 239 delDocs :: CorpusId -> Documents -> Cmd err [Int]
 240 delDocs cId ds = nodesToTrash $ map (\n -> (cId, n, True)) $ documents ds
 241
 242 ------------------------------------------------------------------------
 243 type FavApi =  Summary " Favorites label"
 244             :> ReqBody '[JSON] Favorites
 245             :> Put     '[JSON] [Int]
 246           :<|> Summary " Favorites unlabel"
 247             :> ReqBody '[JSON] Favorites
 248             :> Delete  '[JSON] [Int]
 249
 250 data Favorites = Favorites { favorites :: [NodeId]}
 251   deriving (Generic)
 252
 253 instance FromJSON  Favorites
 254 instance ToJSON    Favorites
 255 instance ToSchema  Favorites
 256
 257 putFav :: CorpusId -> Favorites -> Cmd err [Int]
 258 putFav cId fs = nodesToFavorite $ map (\n -> (cId, n, True)) $ favorites fs
 259
 260 delFav :: CorpusId -> Favorites -> Cmd err [Int]
 261 delFav cId fs = nodesToFavorite $ map (\n -> (cId, n, False)) $ favorites fs
 262
 263 favApi :: CorpusId -> GargServer FavApi
 264 favApi cId = putFav cId :<|> delFav cId
 265
 266 ------------------------------------------------------------------------
 267 type TableApi = Summary " Table API"
 268               :> QueryParam "view"   TabType
 269               :> QueryParam "offset" Int
 270               :> QueryParam "limit"  Int
 271               :> QueryParam "order"  OrderBy
 272               :> Get '[JSON] [FacetDoc]
 273
 274 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 275 type PairingApi = Summary " Pairing API"
 276               :> QueryParam "view"   TabType -- TODO change TabType -> DocType (CorpusId for pairing)
 277               :> QueryParam "offset" Int
 278               :> QueryParam "limit"  Int
 279               :> QueryParam "order"  OrderBy
 280               :> Get '[JSON] [FacetDoc]
 281
 282 ------------------------------------------------------------------------
 283 type ChartApi = Summary " Chart API"
 284               :> QueryParam "from" UTCTime
 285               :> QueryParam "to"   UTCTime
 286               :> Get '[JSON] (ChartMetrics Histo)
 287
 288 type PieApi = Summary " Chart API"
 289            :> QueryParam "from" UTCTime
 290            :> QueryParam "to"   UTCTime
 291            :> QueryParamR "ngramsType" TabType
 292            :> Get '[JSON] (ChartMetrics Histo)
 293
 294 type TreeApi = Summary " Tree API"
 295            :> QueryParam "from" UTCTime
 296            :> QueryParam "to"   UTCTime
 297            :> QueryParamR "ngramsType" TabType
 298            :> QueryParamR "listType"   ListType
 299            :> Get '[JSON] (ChartMetrics [MyTree])
 300
 301
 302
 303                 -- Depending on the Type of the Node, we could post
 304                 -- New documents for a corpus
 305                 -- New map list terms
 306              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 307
 308                 -- To launch a query and update the corpus
 309              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 310
 311 ------------------------------------------------------------------------
 312
 313
 314 instance HasNodeError ServantErr where
 315   _NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism")
 316     where
 317       e = "Gargantext NodeError: "
 318       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 319       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 320       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 321       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 322
 323       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 324       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 325       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 326       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 327       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 328       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 329       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 330
 331 -- TODO(orphan): There should be a proper APIError data type with a case TreeError.
 332 instance HasTreeError ServantErr where
 333   _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
 334     where
 335       e = "TreeError: "
 336       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 337       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 338       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 339
 340 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 341 -- TODO-ACCESS: CanTree or CanGetNode
 342 -- TODO-EVENTS: No events as this is a read only query.
 343 treeAPI :: NodeId -> GargServer TreeAPI
 344 treeAPI = treeDB
 345
 346 ------------------------------------------------------------------------
 347 -- | Check if the name is less than 255 char
 348 rename :: NodeId -> RenameNode -> Cmd err [Int]
 349 rename nId (RenameNode name') = U.update (U.Rename nId name')
 350
 351 getTable :: NodeId -> Maybe TabType
 352          -> Maybe Offset  -> Maybe Limit
 353          -> Maybe OrderBy -> Cmd err [FacetDoc]
 354 getTable cId ft o l order =
 355   case ft of
 356     (Just Docs)  -> runViewDocuments cId False o l order
 357     (Just Trash) -> runViewDocuments cId True  o l order
 358     _     -> panic "not implemented"
 359
 360 getPairing :: ContactId -> Maybe TabType
 361          -> Maybe Offset  -> Maybe Limit
 362          -> Maybe OrderBy -> Cmd err [FacetDoc]
 363 getPairing cId ft o l order =
 364   case ft of
 365     (Just Docs)  -> runViewAuthorsDoc cId False o l order
 366     (Just Trash) -> runViewAuthorsDoc cId True  o l order
 367     _     -> panic "not implemented"
 368
 369 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
 370 postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
 371
 372 putNode :: NodeId -> Cmd err Int
 373 putNode = undefined -- TODO
 374
 375 query :: Monad m => Text -> m Text
 376 query s = pure s
 377
 378
 379 -------------------------------------------------------------
 380 type MetricsAPI = Summary "SepGen IncExc metrics"
 381                 :> QueryParam  "list"       ListId
 382                 :> QueryParamR "ngramsType" TabType
 383                 :> QueryParam  "limit"      Int
 384                 :> Get '[JSON] Metrics
 385
 386 getMetrics :: NodeId -> GargServer MetricsAPI
 387 getMetrics cId maybeListId tabType maybeLimit = do
 388   (ngs', scores) <- Metrics.getMetrics' cId maybeListId tabType maybeLimit
 389
 390   let
 391     metrics      = map (\(Scored t s1 s2) -> Metric t (log' 5 s1) (log' 2 s2) (listType t ngs')) scores
 392     log' n x     = 1 + (if x <= 0 then 0 else (log $ (10^(n::Int)) * x))
 393     listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
 394     errorMsg     = "API.Node.metrics: key absent"
 395
 396   pure $ Metrics metrics
 397
 398
 399 -------------------------------------------------------------
 400 type Hash = Text
 401
 402 instance ToParamSchema (MultipartData Mem) where
 403   toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
 404
 405 instance (ToParamSchema a, HasSwagger sub) =>
 406          HasSwagger (MultipartForm tag a :> sub) where
 407   -- TODO
 408   toSwagger _ = toSwagger (Proxy :: Proxy sub)
 409     & addParam param
 410     where
 411       param = mempty
 412         & required ?~ True
 413         & schema   .~ ParamOther sch
 414       sch = mempty
 415         & in_         .~ ParamFormData
 416         & paramSchema .~ toParamSchema (Proxy :: Proxy a)
 417
 418 type UploadAPI = Summary "Upload file(s) to a corpus"
 419                 :> MultipartForm Mem (MultipartData Mem)
 420                 :> Post '[JSON] [Hash]
 421
 422 postUpload :: NodeId -> GargServer UploadAPI
 423 postUpload _ multipartData = do
 424   is <- liftIO $ do
 425     putStrLn ("Inputs:" :: Text)
 426     forM (inputs multipartData) $ \input -> do
 427       putStrLn $ ("iName  " :: Text) <> (iName input)
 428             <> ("iValue " :: Text) <> (iValue input)
 429       pure $ iName input
 430
 431   _ <- forM (files multipartData) $ \file -> do
 432     let content = fdPayload file
 433     putStrLn $ ("XXX " :: Text) <> (fdFileName file)
 434     putStrLn $ ("YYY " :: Text) <>  cs content
 435     --pure $ cs content
 436   -- is <- inputs multipartData
 437
 438   pure $ map (hash . cs) is