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