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 ((.~), (?~))
  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 (SearchDocsAPI, searchDocs, SearchQuery(..))
  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, HasNodeError(..))
  62 import Gargantext.Database.Schema.NodeNode (nodeNodesCategory)
  63 import Gargantext.Database.Tree (treeDB)
  64 import Gargantext.Database.Types.Node
  65 import Gargantext.Database.TextSearch
  66 import Gargantext.Database.Utils -- (Cmd, CmdM)
  67 import Gargantext.Database.Learn (FavOrTrash(..), moreLike)
  68 import Gargantext.Prelude
  69 import Gargantext.Prelude.Utils (hash)
  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] [NodeAny]
 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              :<|> "upload"    :> UploadAPI
 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 ------------------------------------------------------------------------
 164 -- TODO: make the NodeId type indexed by `a`, then we no longer need the proxy.
 165 nodeAPI :: JSONB a => proxy a -> UserId -> NodeId -> GargServer (NodeAPI a)
 166 nodeAPI p uId id
 167              =  getNode       id p
 168            :<|> rename        id
 169            :<|> postNode  uId id
 170            :<|> putNode       id
 171            :<|> deleteNodeApi id
 172            :<|> getChildren   id p
 173
 174            -- TODO gather it
 175            :<|> tableApi             id
 176            :<|> apiNgramsTableCorpus id
 177            :<|> getPairing           id
 178            -- :<|> getTableNgramsDoc id
 179
 180            :<|> catApi     id
 181
 182            :<|> searchDocs id
 183
 184            :<|> getScatter id
 185            :<|> getChart   id
 186            :<|> getPie     id
 187            :<|> getTree    id
 188            :<|> phyloAPI   id uId
 189            :<|> postUpload id
 190   where
 191     deleteNodeApi id' = do
 192       node <- getNode' id'
 193       if _node_typename node == nodeTypeId NodeUser
 194          then panic "not allowed"  -- TODO add proper Right Management Type
 195          else deleteNode id'
 196
 197            -- Annuaire
 198            -- :<|> query
 199 ------------------------------------------------------------------------
 200 data RenameNode = RenameNode { r_name :: Text }
 201   deriving (Generic)
 202
 203 instance FromJSON  RenameNode
 204 instance ToJSON    RenameNode
 205 instance ToSchema  RenameNode
 206 instance Arbitrary RenameNode where
 207   arbitrary = elements [RenameNode "test"]
 208 ------------------------------------------------------------------------
 209 data PostNode = PostNode { pn_name :: Text
 210                          , pn_typename :: NodeType}
 211   deriving (Generic)
 212
 213 instance FromJSON  PostNode
 214 instance ToJSON    PostNode
 215 instance ToSchema  PostNode
 216 instance Arbitrary PostNode where
 217   arbitrary = elements [PostNode "Node test" NodeCorpus]
 218
 219 ------------------------------------------------------------------------
 220 type CatApi =  Summary " To Categorize NodeNodes: 0 for delete, 1/null neutral, 2 favorite"
 221             :> ReqBody '[JSON] NodesToCategory
 222             :> Put     '[JSON] [Int]
 223
 224 data NodesToCategory = NodesToCategory { ntc_nodesId :: [NodeId]
 225                                        , ntc_category :: Int
 226                                        }
 227   deriving (Generic)
 228
 229 instance FromJSON  NodesToCategory
 230 instance ToJSON    NodesToCategory
 231 instance ToSchema  NodesToCategory
 232
 233 catApi :: CorpusId -> GargServer CatApi
 234 catApi = putCat
 235   where
 236     putCat :: CorpusId -> NodesToCategory -> Cmd err [Int]
 237     putCat cId cs' = nodeNodesCategory $ map (\n -> (cId, n, ntc_category cs')) (ntc_nodesId cs')
 238
 239
 240 ------------------------------------------------------------------------
 241 type TableApi = Summary " Table API"
 242               :> ReqBody '[JSON] SearchQuery
 243               :> QueryParam "view"   TabType
 244               :> QueryParam "offset" Int
 245               :> QueryParam "limit"  Int
 246               :> QueryParam "order"  OrderBy
 247               :> Post '[JSON] [FacetDoc]
 248
 249 -- TODO adapt FacetDoc -> ListDoc (and add type of document as column)
 250 type PairingApi = Summary " Pairing API"
 251               :> QueryParam "view"   TabType
 252               -- TODO change TabType -> DocType (CorpusId for pairing)
 253               :> QueryParam "offset" Int
 254               :> QueryParam "limit"  Int
 255               :> QueryParam "order"  OrderBy
 256               :> Get '[JSON] [FacetDoc]
 257
 258 ------------------------------------------------------------------------
 259 type ChartApi = Summary " Chart API"
 260               :> QueryParam "from" UTCTime
 261               :> QueryParam "to"   UTCTime
 262               :> Get '[JSON] (ChartMetrics Histo)
 263
 264 type PieApi = Summary " Chart API"
 265            :> QueryParam "from" UTCTime
 266            :> QueryParam "to"   UTCTime
 267            :> QueryParamR "ngramsType" TabType
 268            :> Get '[JSON] (ChartMetrics Histo)
 269
 270 type TreeApi = Summary " Tree API"
 271            :> QueryParam "from" UTCTime
 272            :> QueryParam "to"   UTCTime
 273            :> QueryParamR "ngramsType" TabType
 274            :> QueryParamR "listType"   ListType
 275            :> Get '[JSON] (ChartMetrics [MyTree])
 276
 277                 -- Depending on the Type of the Node, we could post
 278                 -- New documents for a corpus
 279                 -- New map list terms
 280              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 281
 282                 -- To launch a query and update the corpus
 283              -- :<|> "query"    :> Capture "string" Text       :> Get  '[JSON] Text
 284
 285 ------------------------------------------------------------------------
 286
 287 {-
 288 NOTE: These instances are not necessary. However, these messages could be part
 289       of a display function for NodeError/TreeError.
 290 instance HasNodeError ServantErr where
 291   _NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism")
 292     where
 293       e = "Gargantext NodeError: "
 294       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 295       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 296       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 297       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 298
 299       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 300       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 301       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 302       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 303       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 304       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 305       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 306
 307 instance HasTreeError ServantErr where
 308   _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
 309     where
 310       e = "TreeError: "
 311       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 312       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 313       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 314 -}
 315
 316 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 317 -- TODO-ACCESS: CanTree or CanGetNode
 318 -- TODO-EVENTS: No events as this is a read only query.
 319 treeAPI :: NodeId -> GargServer TreeAPI
 320 treeAPI = treeDB
 321
 322 ------------------------------------------------------------------------
 323 -- | Check if the name is less than 255 char
 324 rename :: NodeId -> RenameNode -> Cmd err [Int]
 325 rename nId (RenameNode name') = U.update (U.Rename nId name')
 326
 327 tableApi :: NodeId -> SearchQuery
 328          -> Maybe TabType
 329          -> Maybe Offset  -> Maybe Limit
 330          -> Maybe OrderBy -> Cmd err [FacetDoc]
 331 tableApi cId (SearchQuery []) ft o l order = getTable cId ft o l order
 332 tableApi cId (SearchQuery q)  ft o l order = case ft of
 333       Just Docs  -> searchInCorpus cId q o l order
 334       Just Trash -> panic "TODO search in Trash" -- TODO searchInCorpus cId q o l order
 335       _          -> panic "not implemented: search in Fav/Trash/*"
 336
 337 getTable :: NodeId -> Maybe TabType
 338          -> Maybe Offset  -> Maybe Limit
 339          -> Maybe OrderBy -> Cmd err [FacetDoc]
 340 getTable cId ft o l order =
 341   case ft of
 342     (Just Docs)  -> runViewDocuments cId False o l order
 343     (Just Trash) -> runViewDocuments cId True  o l order
 344     (Just MoreFav)   -> moreLike cId o l order IsFav
 345     (Just MoreTrash) -> moreLike cId o l order IsTrash
 346     _     -> panic "not implemented"
 347
 348 getPairing :: ContactId -> Maybe TabType
 349          -> Maybe Offset  -> Maybe Limit
 350          -> Maybe OrderBy -> Cmd err [FacetDoc]
 351 getPairing cId ft o l order =
 352   case ft of
 353     (Just Docs)  -> runViewAuthorsDoc cId False o l order
 354     (Just Trash) -> runViewAuthorsDoc cId True  o l order
 355     _     -> panic "not implemented"
 356
 357 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
 358 postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
 359
 360 putNode :: NodeId -> Cmd err Int
 361 putNode = undefined -- TODO
 362
 363 query :: Monad m => Text -> m Text
 364 query s = pure s
 365
 366 -------------------------------------------------------------
 367 type Hash = Text
 368 data FileType = CSV | PresseRIS
 369   deriving (Eq, Show, Generic)
 370
 371 instance ToSchema FileType
 372 instance Arbitrary FileType
 373   where
 374     arbitrary = elements [CSV, PresseRIS]
 375 instance ToParamSchema FileType
 376
 377 instance ToParamSchema (MultipartData Mem) where
 378   toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
 379
 380 instance FromHttpApiData FileType
 381   where
 382     parseUrlPiece "CSV"       = pure CSV
 383     parseUrlPiece "PresseRis" = pure PresseRIS
 384     parseUrlPiece _           = pure CSV -- TODO error here
 385
 386
 387 instance (ToParamSchema a, HasSwagger sub) =>
 388          HasSwagger (MultipartForm tag a :> sub) where
 389   -- TODO
 390   toSwagger _ = toSwagger (Proxy :: Proxy sub)
 391     & addParam param
 392     where
 393       param = mempty
 394         & required ?~ True
 395         & schema   .~ ParamOther sch
 396       sch = mempty
 397         & in_         .~ ParamFormData
 398         & paramSchema .~ toParamSchema (Proxy :: Proxy a)
 399
 400 type UploadAPI = Summary "Upload file(s) to a corpus"
 401                 :> MultipartForm Mem (MultipartData Mem)
 402                 :> QueryParam "fileType"  FileType
 403                 :> Post '[JSON] [Hash]
 404
 405 --postUpload :: NodeId -> Maybe FileType ->  GargServer UploadAPI
 406 --postUpload :: NodeId -> GargServer UploadAPI
 407 postUpload :: NodeId -> MultipartData Mem -> Maybe FileType -> Cmd err [Hash]
 408 postUpload _ _ Nothing = panic "fileType is a required parameter"
 409 postUpload _ multipartData (Just fileType) = do
 410   putStrLn $ "File Type: " <> (show fileType)
 411   is <- liftIO $ do
 412     putStrLn ("Inputs:" :: Text)
 413     forM (inputs multipartData) $ \input -> do
 414       putStrLn $ ("iName  " :: Text) <> (iName input)
 415             <> ("iValue " :: Text) <> (iValue input)
 416       pure $ iName input
 417
 418   _ <- forM (files multipartData) $ \file -> do
 419     let content = fdPayload file
 420     putStrLn $ ("XXX " :: Text) <> (fdFileName file)
 421     putStrLn $ ("YYY " :: Text) <>  cs content
 422     --pure $ cs content
 423   -- is <- inputs multipartData
 424
 425   pure $ map (hash . cs) is