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