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 -- TODO-SECURITY: Critical
  11
  12 -- TODO-ACCESS: CanGetNode
  13 -- TODO-EVENTS: No events as this is a read only query.
  14 Node API
  15
  16 -------------------------------------------------------------------
  17 -- TODO-ACCESS: access by admin only.
  18 --              At first let's just have an isAdmin check.
  19 --              Later: check userId CanDeleteNodes Nothing
  20 -- TODO-EVENTS: DeletedNodes [NodeId]
  21 --              {"tag": "DeletedNodes", "nodes": [Int*]}
  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 ((.~), (?~), (^.))
  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.Auth (withAccess, PathId(..))
  52 import Gargantext.API.Metrics
  53 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, apiNgramsTableCorpus, QueryParamR, TODO)
  54 import Gargantext.API.Ngrams.NTree (MyTree)
  55 import Gargantext.API.Search (SearchDocsAPI, searchDocs)
  56 import Gargantext.API.Table
  57 import Gargantext.API.Types
  58 import Gargantext.Core.Types (NodeTableResult)
  59 import Gargantext.Core.Types.Main (Tree, NodeTree, ListType)
  60 import Gargantext.Database.Config (nodeTypeId)
  61 import Gargantext.Database.Facet (FacetDoc, OrderBy(..))
  62 import Gargantext.Database.Node.Children (getChildren)
  63 import Gargantext.Database.Schema.Node ( getNodesWithParentId, getNode, getNode', deleteNode, deleteNodes, mkNodeWithParent, JSONB, HasNodeError(..))
  64 import Gargantext.Database.Schema.NodeNode (nodeNodesCategory)
  65 import Gargantext.Database.Tree (treeDB)
  66 import Gargantext.Database.Types.Node
  67 import Gargantext.Database.Utils -- (Cmd, CmdM)
  68 import Gargantext.Prelude
  69 import Gargantext.Prelude.Utils (sha)
  70 import Gargantext.Viz.Chart
  71 import Gargantext.Viz.Phylo.API (PhyloAPI, phyloAPI)
  72 import Servant
  73 import Servant.Multipart
  74 import Servant.Swagger (HasSwagger(toSwagger))
  75 import Servant.Swagger.Internal
  76 import Test.QuickCheck (elements)
  77 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  78 import qualified Gargantext.Database.Node.Update as U (update, Update(..))
  79
  80 {-
  81 import qualified Gargantext.Text.List.Learn as Learn
  82 import qualified Data.Vector as Vec
  83 --}
  84
  85
  86 type NodesAPI  = Delete '[JSON] Int
  87
  88 -- | Delete Nodes
  89 -- Be careful: really delete nodes
  90 -- Access by admin only
  91 nodesAPI :: [NodeId] -> GargServer NodesAPI
  92 nodesAPI ids = deleteNodes ids
  93
  94 ------------------------------------------------------------------------
  95 -- | TODO-ACCESS: access by admin only.
  96 -- At first let's just have an isAdmin check.
  97 -- Later: CanAccessAnyNode or (CanGetAnyNode, CanPutAnyNode)
  98 -- To manage the Users roots
  99 -- TODO-EVENTS:
 100 --   PutNode ?
 101 -- TODO needs design discussion.
 102 type Roots =  Get    '[JSON] [Node HyperdataAny]
 103          :<|> Put    '[JSON] Int -- TODO
 104
 105 -- | TODO: access by admin only
 106 roots :: GargServer Roots
 107 roots = (liftIO (putStrLn ( "/user" :: Text)) >> getNodesWithParentId 0 Nothing)
 108    :<|> pure (panic "not implemented yet") -- TODO use patch map to update what we need
 109
 110 -------------------------------------------------------------------
 111 -- | Node API Types management
 112 -- TODO-ACCESS : access by users
 113 -- No ownership check is needed if we strictly follow the capability model.
 114 --
 115 -- CanGetNode (Node, Children, TableApi, TableNgramsApiGet, PairingApi, ChartApi,
 116 --             SearchAPI)
 117 -- CanRenameNode (or part of CanEditNode?)
 118 -- CanCreateChildren (PostNodeApi)
 119 -- CanEditNode / CanPutNode TODO not implemented yet
 120 -- CanDeleteNode
 121 -- CanPatch (TableNgramsApi)
 122 -- CanFavorite
 123 -- CanMoveToTrash
 124
 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              :<|> "category"  :> CatApi
 138              :<|> "search"    :> SearchDocsAPI
 139
 140              -- VIZ
 141              :<|> "metrics" :> ScatterAPI
 142              :<|> "chart"     :> ChartApi
 143              :<|> "pie"       :> PieApi
 144              :<|> "tree"      :> TreeApi
 145              :<|> "phylo"     :> PhyloAPI
 146              :<|> "add"       :> NodeAddAPI
 147
 148 -- TODO-ACCESS: check userId CanRenameNode nodeId
 149 -- TODO-EVENTS: NodeRenamed RenameNode or re-use some more general NodeEdited...
 150 type RenameApi = Summary " Rename Node"
 151                :> ReqBody '[JSON] RenameNode
 152                :> Put     '[JSON] [Int]
 153
 154 type PostNodeApi = Summary " PostNode Node with ParentId as {id}"
 155                  :> ReqBody '[JSON] PostNode
 156                  :> Post    '[JSON] [NodeId]
 157
 158 type ChildrenApi a = Summary " Summary children"
 159                  :> QueryParam "type"   NodeType
 160                  :> QueryParam "offset" Int
 161                  :> QueryParam "limit"  Int
 162                  -- :> Get '[JSON] [Node a]
 163                  :> Get '[JSON] (NodeTableResult a)
 164
 165 ------------------------------------------------------------------------
 166 type NodeNodeAPI a = Get '[JSON] (Node a)
 167
 168 nodeNodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> CorpusId -> NodeId -> GargServer (NodeNodeAPI a)
 169 nodeNodeAPI p uId cId nId = withAccess (Proxy :: Proxy (NodeNodeAPI a)) Proxy uId (PathNodeNode cId nId) nodeNodeAPI'
 170   where
 171     nodeNodeAPI' :: GargServer (NodeNodeAPI a)
 172     nodeNodeAPI' = getNode nId p
 173
 174
 175
 176 ------------------------------------------------------------------------
 177 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 178 nodeAPI :: forall proxy a. (JSONB a, ToJSON a) => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
 179 nodeAPI p uId id = withAccess (Proxy :: Proxy (NodeAPI a)) Proxy uId (PathNode id) nodeAPI'
 180   where
 181     nodeAPI' :: GargServer (NodeAPI a)
 182     nodeAPI' =  getNode       id p
 183            :<|> rename        id
 184            :<|> postNode  uId id
 185            :<|> putNode       id
 186            :<|> deleteNodeApi id
 187            :<|> getChildren   id p
 188
 189            -- TODO gather it
 190            :<|> tableApi             id
 191            :<|> apiNgramsTableCorpus id
 192            -- :<|> getPairing           id
 193            -- :<|> getTableNgramsDoc id
 194
 195            :<|> catApi     id
 196
 197            :<|> searchDocs id
 198
 199            :<|> getScatter id
 200            :<|> getChart   id
 201            :<|> getPie     id
 202            :<|> getTree    id
 203            :<|> phyloAPI   id uId
 204            :<|> nodeAddAPI id
 205            -- :<|> postUpload id
 206
 207     deleteNodeApi id' = do
 208       node <- getNode' id'
 209       if _node_typename node == nodeTypeId NodeUser
 210          then panic "not allowed"  -- TODO add proper Right Management Type
 211          else deleteNode id'
 212
 213            -- Annuaire
 214            -- :<|> query
 215
 216
 217 ------------------------------------------------------------------------
 218 data RenameNode = RenameNode { r_name :: Text }
 219   deriving (Generic)
 220
 221 -- TODO unPrefix "r_" FromJSON, ToJSON, ToSchema, adapt frontend.
 222 instance FromJSON  RenameNode
 223 instance ToJSON    RenameNode
 224 instance ToSchema  RenameNode
 225 instance Arbitrary RenameNode where
 226   arbitrary = elements [RenameNode "test"]
 227 ------------------------------------------------------------------------
 228 data PostNode = PostNode { pn_name :: Text
 229                          , pn_typename :: NodeType}
 230   deriving (Generic)
 231
 232 -- TODO unPrefix "pn_" FromJSON, ToJSON, ToSchema, adapt frontend.
 233 instance FromJSON  PostNode
 234 instance ToJSON    PostNode
 235 instance ToSchema  PostNode
 236 instance Arbitrary PostNode where
 237   arbitrary = elements [PostNode "Node test" NodeCorpus]
 238
 239 ------------------------------------------------------------------------
 240 type CatApi =  Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
 241             :> ReqBody '[JSON] NodesToCategory
 242             :> Put     '[JSON] [Int]
 243
 244 data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
 245                                        , ntc_category :: Int
 246                                        }
 247   deriving (Generic)
 248
 249 -- TODO unPrefix "ntc_" FromJSON, ToJSON, ToSchema, adapt frontend.
 250 instance FromJSON  NodesToCategory
 251 instance ToJSON    NodesToCategory
 252 instance ToSchema  NodesToCategory
 253
 254 catApi :: CorpusId -> GargServer CatApi
 255 catApi = putCat
 256   where
 257     putCat :: CorpusId -> NodesToCategory -> Cmd err [Int]
 258     putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
 259
 260 ------------------------------------------------------------------------
 261 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 262 type PairingApi = Summary " Pairing API"
 263               :> QueryParam "view"   TabType
 264               -- TODO change TabType -> DocType (CorpusId for pairing)
 265               :> QueryParam "offset" Int
 266               :> QueryParam "limit"  Int
 267               :> QueryParam "order"  OrderBy
 268               :> Get '[JSON] [FacetDoc]
 269
 270 ------------------------------------------------------------------------
 271 type ChartApi = Summary " Chart API"
 272               :> QueryParam "from" UTCTime
 273               :> QueryParam "to"   UTCTime
 274               :> Get '[JSON] (ChartMetrics Histo)
 275
 276 type PieApi = Summary " Chart API"
 277            :> QueryParam "from" UTCTime
 278            :> QueryParam "to"   UTCTime
 279            :> QueryParamR "ngramsType" TabType
 280            :> Get '[JSON] (ChartMetrics Histo)
 281
 282 type TreeApi = Summary " Tree API"
 283            :> QueryParam "from" UTCTime
 284            :> QueryParam "to"   UTCTime
 285            :> QueryParamR "ngramsType" TabType
 286            :> QueryParamR "listType"   ListType
 287            :> Get '[JSON] (ChartMetrics [MyTree])
 288
 289                 -- Depending on the Type of the Node, we could post
 290                 -- New documents for a corpus
 291                 -- New map list terms
 292              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 293
 294                 -- To launch a query and update the corpus
 295              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 296
 297 ------------------------------------------------------------------------
 298
 299 {-
 300 NOTE: These instances are not necessary. However, these messages could be part
 301       of a display function for NodeError/TreeError.
 302 instance HasNodeError ServantErr where
 303   _NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism")
 304     where
 305       e = "Gargantext NodeError: "
 306       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 307       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 308       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 309       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 310
 311       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 312       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 313       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 314       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 315       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 316       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 317       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 318
 319 instance HasTreeError ServantErr where
 320   _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
 321     where
 322       e = "TreeError: "
 323       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 324       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 325       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 326 -}
 327
 328 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 329
 330 treeAPI :: NodeId -> GargServer TreeAPI
 331 treeAPI = treeDB
 332
 333 ------------------------------------------------------------------------
 334 -- | Check if the name is less than 255 char
 335 rename :: NodeId -> RenameNode -> Cmd err [Int]
 336 rename nId (RenameNode name') = U.update (U.Rename nId name')
 337
 338 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
 339 postNode uId pId (PostNode nodeName nt) = do
 340   nodeUser <- getNode (NodeId uId) HyperdataUser
 341   let uId' = nodeUser ^. node_userId
 342   mkNodeWithParent nt (Just pId) uId' nodeName
 343
 344 putNode :: NodeId -> Cmd err Int
 345 putNode = undefined -- TODO
 346
 347 query :: Monad m => Text -> m Text
 348 query s = pure s
 349
 350 -------------------------------------------------------------
 351 type Hash = Text
 352 data FileType = CSV | PresseRIS
 353   deriving (Eq, Show, Generic)
 354
 355 instance ToSchema FileType
 356 instance Arbitrary FileType
 357   where
 358     arbitrary = elements [CSV, PresseRIS]
 359 instance ToParamSchema FileType
 360
 361 instance ToParamSchema (MultipartData Mem) where
 362   toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
 363
 364 instance FromHttpApiData FileType
 365   where
 366     parseUrlPiece "CSV"       = pure CSV
 367     parseUrlPiece "PresseRis" = pure PresseRIS
 368     parseUrlPiece _           = pure CSV -- TODO error here
 369
 370
 371 instance (ToParamSchema a, HasSwagger sub) =>
 372          HasSwagger (MultipartForm tag a :> sub) where
 373   -- TODO
 374   toSwagger _ = toSwagger (Proxy :: Proxy sub)
 375     & addParam param
 376     where
 377       param = mempty
 378         & required ?~ True
 379         & schema   .~ ParamOther sch
 380       sch = mempty
 381         & in_         .~ ParamFormData
 382         & paramSchema .~ toParamSchema (Proxy :: Proxy a)
 383
 384 type NodeAddAPI = "file" :> Summary "Node add API"
 385                          :> UploadAPI
 386
 387 nodeAddAPI :: NodeId -> GargServer NodeAddAPI
 388 nodeAddAPI id =  postUpload       id
 389
 390 type UploadAPI = Summary "Upload file(s) to a corpus"
 391                 :> MultipartForm Mem (MultipartData Mem)
 392                 :> QueryParam "fileType"  FileType
 393                 :> Post '[JSON] [Hash]
 394
 395 --postUpload :: NodeId -> Maybe FileType ->  GargServer UploadAPI
 396 --postUpload :: NodeId -> GargServer UploadAPI
 397 postUpload :: NodeId -> MultipartData Mem -> Maybe FileType -> Cmd err [Hash]
 398 postUpload _ _ Nothing = panic "fileType is a required parameter"
 399 postUpload _ multipartData (Just fileType) = do
 400   putStrLn $ "File Type: " <> (show fileType)
 401   is <- liftIO $ do
 402     putStrLn ("Inputs:" :: Text)
 403     forM (inputs multipartData) $ \input -> do
 404       putStrLn $ ("iName  " :: Text) <> (iName input)
 405             <> ("iValue " :: Text) <> (iValue input)
 406       pure $ iName input
 407
 408   _ <- forM (files multipartData) $ \file -> do
 409     let content = fdPayload file
 410     putStrLn $ ("XXX " :: Text) <> (fdFileName file)
 411     putStrLn $ ("YYY " :: Text) <>  cs content
 412     --pure $ cs content
 413   -- is <- inputs multipartData
 414
 415   pure $ map (sha . cs) is