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)
  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 (nodesToFavorite, nodesToTrash)
  63 import Gargantext.Database.Tree (treeDB)
  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 NOTE: These instances are not necessary. However, these messages could be part
 307       of a display function for NodeError/TreeError.
 308 instance HasNodeError ServantErr where
 309   _NodeError = prism' mk (const Nothing) -- panic "HasNodeError ServantErr: not a prism")
 310     where
 311       e = "Gargantext NodeError: "
 312       mk NoListFound   = err404 { errBody = e <> "No list found"         }
 313       mk NoRootFound   = err404 { errBody = e <> "No Root found"         }
 314       mk NoCorpusFound = err404 { errBody = e <> "No Corpus found"       }
 315       mk NoUserFound   = err404 { errBody = e <> "No User found"         }
 316
 317       mk MkNode        = err500 { errBody = e <> "Cannot mk node"        }
 318       mk NegativeId    = err500 { errBody = e <> "Node with negative Id" }
 319       mk UserNoParent  = err500 { errBody = e <> "Should not have parent"}
 320       mk HasParent     = err500 { errBody = e <> "NodeType has parent"   }
 321       mk NotImplYet    = err500 { errBody = e <> "Not implemented yet"   }
 322       mk ManyParents   = err500 { errBody = e <> "Too many parents"      }
 323       mk ManyNodeUsers = err500 { errBody = e <> "Many userNode/user"    }
 324
 325 instance HasTreeError ServantErr where
 326   _TreeError = prism' mk (const Nothing) -- panic "HasTreeError ServantErr: not a prism")
 327     where
 328       e = "TreeError: "
 329       mk NoRoot       = err404 { errBody = e <> "Root node not found"           }
 330       mk EmptyRoot    = err500 { errBody = e <> "Root node should not be empty" }
 331       mk TooManyRoots = err500 { errBody = e <> "Too many root nodes"           }
 332 -}
 333
 334 type TreeAPI   = Get '[JSON] (Tree NodeTree)
 335 -- TODO-ACCESS: CanTree or CanGetNode
 336 -- TODO-EVENTS: No events as this is a read only query.
 337 treeAPI :: NodeId -> GargServer TreeAPI
 338 treeAPI = treeDB
 339
 340 ------------------------------------------------------------------------
 341 -- | Check if the name is less than 255 char
 342 rename :: NodeId -> RenameNode -> Cmd err [Int]
 343 rename nId (RenameNode name') = U.update (U.Rename nId name')
 344
 345 getTable :: NodeId -> Maybe TabType
 346          -> Maybe Offset  -> Maybe Limit
 347          -> Maybe OrderBy -> Cmd err [FacetDoc]
 348 getTable cId ft o l order =
 349   case ft of
 350     (Just Docs)  -> runViewDocuments cId False o l order
 351     (Just Trash) -> runViewDocuments cId True  o l order
 352     _     -> panic "not implemented"
 353
 354 getPairing :: ContactId -> Maybe TabType
 355          -> Maybe Offset  -> Maybe Limit
 356          -> Maybe OrderBy -> Cmd err [FacetDoc]
 357 getPairing cId ft o l order =
 358   case ft of
 359     (Just Docs)  -> runViewAuthorsDoc cId False o l order
 360     (Just Trash) -> runViewAuthorsDoc cId True  o l order
 361     _     -> panic "not implemented"
 362
 363 postNode :: HasNodeError err => UserId -> NodeId -> PostNode -> Cmd err [NodeId]
 364 postNode uId pId (PostNode nodeName nt) = mkNodeWithParent nt (Just pId) uId nodeName
 365
 366 putNode :: NodeId -> Cmd err Int
 367 putNode = undefined -- TODO
 368
 369 query :: Monad m => Text -> m Text
 370 query s = pure s
 371
 372 -------------------------------------------------------------
 373 type Hash = Text
 374 data FileType = CSV | PresseRIS
 375   deriving (Eq, Show, Generic)
 376
 377 instance ToSchema FileType
 378 instance Arbitrary FileType
 379   where
 380     arbitrary = elements [CSV, PresseRIS]
 381 instance ToParamSchema FileType
 382
 383 instance ToParamSchema (MultipartData Mem) where
 384   toParamSchema _ = toParamSchema (Proxy :: Proxy TODO)
 385
 386 instance FromHttpApiData FileType
 387   where
 388     parseUrlPiece "CSV"       = pure CSV
 389     parseUrlPiece "PresseRis" = pure PresseRIS
 390     parseUrlPiece _           = pure CSV -- TODO error here
 391
 392
 393 instance (ToParamSchema a, HasSwagger sub) =>
 394          HasSwagger (MultipartForm tag a :> sub) where
 395   -- TODO
 396   toSwagger _ = toSwagger (Proxy :: Proxy sub)
 397     & addParam param
 398     where
 399       param = mempty
 400         & required ?~ True
 401         & schema   .~ ParamOther sch
 402       sch = mempty
 403         & in_         .~ ParamFormData
 404         & paramSchema .~ toParamSchema (Proxy :: Proxy a)
 405
 406 type UploadAPI = Summary "Upload file(s) to a corpus"
 407                 :> MultipartForm Mem (MultipartData Mem)
 408                 :> QueryParam "fileType"  FileType
 409                 :> Post '[JSON] [Hash]
 410
 411 --postUpload :: NodeId -> Maybe FileType ->  GargServer UploadAPI
 412 --postUpload :: NodeId -> GargServer UploadAPI
 413 postUpload :: NodeId -> MultipartData Mem -> Maybe FileType -> Cmd err [Hash]
 414 postUpload _ _ Nothing = panic "fileType is a required parameter"
 415 postUpload _ multipartData (Just fileType) = do
 416   putStrLn $ "File Type: " <> (show fileType)
 417   is <- liftIO $ do
 418     putStrLn ("Inputs:" :: Text)
 419     forM (inputs multipartData) $ \input -> do
 420       putStrLn $ ("iName  " :: Text) <> (iName input)
 421             <> ("iValue " :: Text) <> (iValue input)
 422       pure $ iName input
 423
 424   _ <- forM (files multipartData) $ \file -> do
 425     let content = fdPayload file
 426     putStrLn $ ("XXX " :: Text) <> (fdFileName file)
 427     putStrLn $ ("YYY " :: Text) <>  cs content
 428     --pure $ cs content
 429   -- is <- inputs multipartData
 430
 431   pure $ map (hash . cs) is