src/Gargantext/API/Metrics.hs

   1 {-|
   2 Module      : Gargantext.API.Metrics
   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 Metrics API
  11
  12 -}
  13
  14 {-# OPTIONS_GHC -fno-warn-orphans #-}
  15
  16 {-# LANGUAGE TypeOperators      #-}
  17
  18 module Gargantext.API.Metrics
  19     where
  20
  21 import Control.Lens
  22 import qualified Data.Map as Map
  23 import Data.Text (Text)
  24 import Data.Time (UTCTime)
  25 import Servant
  26
  27 import Gargantext.API.HashedResponse
  28 import Gargantext.API.Ngrams.NTree
  29 import Gargantext.API.Ngrams.Types
  30 import Gargantext.API.Prelude (GargServer)
  31 import Gargantext.Core.Types (CorpusId, Limit, ListId, ListType(..))
  32 import Gargantext.Database.Action.Flow
  33 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..), hl_chart, hl_pie, hl_scatter, hl_tree)
  34 import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metric(..), Metrics(..))
  35 import Gargantext.Database.Admin.Types.Node (NodeId)
  36 import Gargantext.Database.Prelude
  37 import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
  38 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  39 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  40 import Gargantext.Database.Schema.Node (node_hyperdata)
  41 import Gargantext.Prelude
  42 import Gargantext.Core.Text.Metrics (Scored(..), {-normalizeGlobal,-} normalizeLocal)
  43 import Gargantext.Core.Viz.Chart
  44 import Gargantext.Core.Viz.Types
  45 import qualified Gargantext.Database.Action.Metrics as Metrics
  46
  47 -------------------------------------------------------------
  48 -- | Scatter metrics API
  49 type ScatterAPI = Summary "SepGen IncExc metrics"
  50                   :> QueryParam  "list"       ListId
  51                   :> QueryParamR "ngramsType" TabType
  52                   :> QueryParam  "limit"      Int
  53                   :> Get '[JSON] (HashedResponse Metrics)
  54               :<|> Summary "Scatter update"
  55                   :> QueryParam  "list"       ListId
  56                   :> QueryParamR "ngramsType" TabType
  57                   :> QueryParam  "limit"      Int
  58                   :> Post '[JSON] ()
  59               :<|> "hash" :> Summary "Scatter Hash"
  60                           :> QueryParam  "list"       ListId
  61                           :> QueryParamR "ngramsType" TabType
  62                           :> Get '[JSON] Text
  63
  64 scatterApi :: NodeId -> GargServer ScatterAPI
  65 scatterApi id' = getScatter id'
  66             :<|> updateScatter id'
  67             :<|> getScatterHash id'
  68
  69 getScatter :: FlowCmdM env err m =>
  70   CorpusId
  71   -> Maybe ListId
  72   -> TabType
  73   -> Maybe Limit
  74   -> m (HashedResponse Metrics)
  75 getScatter cId maybeListId tabType _maybeLimit = do
  76   listId <- case maybeListId of
  77     Just lid -> pure lid
  78     Nothing  -> defaultList cId
  79   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
  80   let HyperdataList { _hl_scatter = scatterMap } = node ^. node_hyperdata
  81       mChart = Map.lookup tabType scatterMap
  82
  83   chart <- case mChart of
  84     Just chart -> pure chart
  85     Nothing    -> do
  86       updateScatter' cId maybeListId tabType Nothing
  87
  88   pure $ constructHashedResponse chart
  89
  90 updateScatter :: FlowCmdM env err m =>
  91   CorpusId
  92   -> Maybe ListId
  93   -> TabType
  94   -> Maybe Limit
  95   -> m ()
  96 updateScatter cId maybeListId tabType maybeLimit = do
  97   printDebug "[updateScatter] cId" cId
  98   printDebug "[updateScatter] maybeListId" maybeListId
  99   printDebug "[updateScatter] tabType" tabType
 100   printDebug "[updateScatter] maybeLimit" maybeLimit
 101   _ <- updateScatter' cId maybeListId tabType maybeLimit
 102   pure ()
 103
 104 updateScatter' :: FlowCmdM env err m =>
 105   CorpusId
 106   -> Maybe ListId
 107   -> TabType
 108   -> Maybe Limit
 109   -> m Metrics
 110 updateScatter' cId maybeListId tabType maybeLimit = do
 111   (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
 112
 113   let
 114     metrics      = map (\(Scored t s1 s2) -> Metric t s1 s2 (listType t ngs'))
 115                  $ map normalizeLocal scores
 116     listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
 117     errorMsg     = "API.Node.metrics: key absent"
 118
 119   listId <- case maybeListId of
 120     Just lid -> pure lid
 121     Nothing  -> defaultList cId
 122   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 123   let hl = node ^. node_hyperdata
 124       scatterMap = hl ^. hl_scatter
 125   _ <- updateHyperdata listId $ hl { _hl_scatter = Map.insert tabType (Metrics metrics) scatterMap }
 126
 127   pure $ Metrics metrics
 128
 129 getScatterHash :: FlowCmdM env err m =>
 130   CorpusId
 131   -> Maybe ListId
 132   -> TabType
 133   -> m Text
 134 getScatterHash cId maybeListId tabType = do
 135   hash <$> getScatter cId maybeListId tabType Nothing
 136
 137
 138 -------------------------------------------------------------
 139 -- | Chart metrics API
 140 type ChartApi = Summary " Chart API"
 141               :> QueryParam "from" UTCTime
 142               :> QueryParam "to"   UTCTime
 143               :> QueryParam  "list"       ListId
 144               :> QueryParamR "ngramsType" TabType
 145               :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
 146             :<|> Summary "Chart update"
 147                :> QueryParam  "list"       ListId
 148                :> QueryParamR "ngramsType" TabType
 149                :> QueryParam  "limit"      Int
 150                :> Post '[JSON] ()
 151             :<|> "hash" :> Summary "Chart Hash"
 152                :> QueryParam  "list"       ListId
 153                :> QueryParamR "ngramsType" TabType
 154                :> Get '[JSON] Text
 155
 156 chartApi :: NodeId -> GargServer ChartApi
 157 chartApi id' = getChart id'
 158           :<|> updateChart id'
 159           :<|> getChartHash id'
 160
 161 -- TODO add start / end
 162 getChart :: FlowCmdM env err m =>
 163             CorpusId
 164          -> Maybe UTCTime
 165          -> Maybe UTCTime
 166          -> Maybe ListId
 167          -> TabType
 168          -> m (HashedResponse (ChartMetrics Histo))
 169 getChart cId _start _end maybeListId tabType = do
 170   listId <- case maybeListId of
 171     Just lid -> pure lid
 172     Nothing  -> defaultList cId
 173   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 174   let chartMap = node ^. node_hyperdata ^. hl_chart
 175       mChart = Map.lookup tabType chartMap
 176
 177   chart <- case mChart of
 178     Just chart -> pure chart
 179     Nothing    -> do
 180       updateChart' cId maybeListId tabType Nothing
 181
 182   pure $ constructHashedResponse chart
 183
 184 updateChart :: HasNodeError err =>
 185   CorpusId
 186   -> Maybe ListId
 187   -> TabType
 188   -> Maybe Limit
 189   -> Cmd err ()
 190 updateChart cId maybeListId tabType maybeLimit = do
 191   printDebug "[updateChart] cId" cId
 192   printDebug "[updateChart] maybeListId" maybeListId
 193   printDebug "[updateChart] tabType" tabType
 194   printDebug "[updateChart] maybeLimit" maybeLimit
 195   _ <- updateChart' cId maybeListId tabType maybeLimit
 196   pure ()
 197
 198 updateChart' :: HasNodeError err =>
 199   CorpusId
 200   -> Maybe ListId
 201   -> TabType
 202   -> Maybe Limit
 203   -> Cmd err (ChartMetrics Histo)
 204 updateChart' cId maybeListId tabType _maybeLimit = do
 205   listId <- case maybeListId of
 206     Just lid -> pure lid
 207     Nothing  -> defaultList cId
 208   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 209   let hl = node ^. node_hyperdata
 210       chartMap = hl ^. hl_chart
 211   h <- histoData cId
 212   _ <- updateHyperdata listId $ hl { _hl_chart = Map.insert tabType (ChartMetrics h) chartMap }
 213
 214   pure $ ChartMetrics h
 215
 216
 217 getChartHash :: FlowCmdM env err m =>
 218   CorpusId
 219   -> Maybe ListId
 220   -> TabType
 221   -> m Text
 222 getChartHash cId maybeListId tabType = do
 223   hash <$> getChart cId Nothing Nothing maybeListId tabType
 224
 225 -------------------------------------------------------------
 226 -- | Pie metrics API
 227 type PieApi = Summary "Pie Chart"
 228            :> QueryParam "from" UTCTime
 229            :> QueryParam "to"   UTCTime
 230            :> QueryParam  "list"       ListId
 231            :> QueryParamR "ngramsType" TabType
 232            :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
 233          :<|> Summary "Pie Chart update"
 234              :> QueryParam  "list"       ListId
 235              :> QueryParamR "ngramsType" TabType
 236              :> QueryParam  "limit"      Int
 237              :> Post '[JSON] ()
 238          :<|> "hash" :> Summary "Pie Hash"
 239                      :> QueryParam  "list"       ListId
 240                      :> QueryParamR "ngramsType" TabType
 241                      :> Get '[JSON] Text
 242
 243 pieApi :: NodeId -> GargServer PieApi
 244 pieApi id' = getPie id'
 245         :<|> updatePie id'
 246         :<|> getPieHash id'
 247
 248 getPie :: FlowCmdM env err m
 249        => CorpusId
 250        -> Maybe UTCTime
 251        -> Maybe UTCTime
 252        -> Maybe ListId
 253        -> TabType
 254        -> m (HashedResponse (ChartMetrics Histo))
 255 getPie cId _start _end maybeListId tabType = do
 256   listId <- case maybeListId of
 257     Just lid -> pure lid
 258     Nothing  -> defaultList cId
 259   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 260   let pieMap = node ^. node_hyperdata ^. hl_pie
 261       mChart = Map.lookup tabType pieMap
 262
 263   chart <- case mChart of
 264     Just chart -> pure chart
 265     Nothing    -> do
 266       updatePie' cId maybeListId tabType Nothing
 267
 268   pure $ constructHashedResponse chart
 269
 270 updatePie :: FlowCmdM env err m =>
 271   CorpusId
 272   -> Maybe ListId
 273   -> TabType
 274   -> Maybe Limit
 275   -> m ()
 276 updatePie cId maybeListId tabType maybeLimit = do
 277   printDebug "[updatePie] cId" cId
 278   printDebug "[updatePie] maybeListId" maybeListId
 279   printDebug "[updatePie] tabType" tabType
 280   printDebug "[updatePie] maybeLimit" maybeLimit
 281   _ <- updatePie' cId maybeListId tabType maybeLimit
 282   pure ()
 283
 284 updatePie' :: FlowCmdM env err m =>
 285   CorpusId
 286   -> Maybe ListId
 287   -> TabType
 288   -> Maybe Limit
 289   -> m (ChartMetrics Histo)
 290 updatePie' cId maybeListId tabType _maybeLimit = do
 291   listId <- case maybeListId of
 292     Just lid -> pure lid
 293     Nothing  -> defaultList cId
 294   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 295   let hl = node ^. node_hyperdata
 296       pieMap = hl ^. hl_pie
 297
 298   p <- chartData cId (ngramsTypeFromTabType tabType) MapTerm
 299   _ <- updateHyperdata listId $ hl { _hl_pie = Map.insert tabType (ChartMetrics p) pieMap }
 300
 301   pure $ ChartMetrics p
 302
 303 getPieHash :: FlowCmdM env err m =>
 304   CorpusId
 305   -> Maybe ListId
 306   -> TabType
 307   -> m Text
 308 getPieHash cId maybeListId tabType = do
 309   hash <$> getPie cId Nothing Nothing maybeListId tabType
 310
 311 -------------------------------------------------------------
 312 -- | Tree metrics API
 313
 314 type TreeApi = Summary " Tree API"
 315            :> QueryParam "from" UTCTime
 316            :> QueryParam "to"   UTCTime
 317            :> QueryParam  "list"       ListId
 318            :> QueryParamR "ngramsType" TabType
 319            :> QueryParamR "listType"   ListType
 320            :> Get '[JSON] (HashedResponse (ChartMetrics [MyTree]))
 321         :<|> Summary "Tree Chart update"
 322                 :> QueryParam  "list"       ListId
 323                 :> QueryParamR "ngramsType" TabType
 324                 :> QueryParamR "listType"   ListType
 325                 :> Post '[JSON] ()
 326           :<|> "hash" :>
 327                   Summary "Tree Hash"
 328               :> QueryParam  "list"       ListId
 329               :> QueryParamR "ngramsType" TabType
 330               :> QueryParamR "listType"   ListType
 331               :> Get '[JSON] Text
 332
 333                 -- Depending on the Type of the Node, we could post
 334                 -- New documents for a corpus
 335                 -- New map list terms
 336              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 337
 338 treeApi :: NodeId -> GargServer TreeApi
 339 treeApi id' = getTree id'
 340          :<|> updateTree id'
 341          :<|> getTreeHash id'
 342
 343 getTree :: FlowCmdM env err m
 344         => CorpusId
 345         -> Maybe UTCTime
 346         -> Maybe UTCTime
 347         -> Maybe ListId
 348         -> TabType
 349         -> ListType
 350         -> m (HashedResponse (ChartMetrics [MyTree]))
 351 getTree cId _start _end maybeListId tabType listType = do
 352   listId <- case maybeListId of
 353     Just lid -> pure lid
 354     Nothing  -> defaultList cId
 355
 356   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 357   let treeMap = node ^. node_hyperdata ^. hl_tree
 358       mChart = Map.lookup tabType treeMap
 359
 360   chart <- case mChart of
 361     Just chart -> pure chart
 362     Nothing    -> do
 363       updateTree' cId maybeListId tabType listType
 364
 365   pure $ constructHashedResponse chart
 366
 367 updateTree :: FlowCmdM env err m =>
 368   CorpusId
 369   -> Maybe ListId
 370   -> TabType
 371   -> ListType
 372   -> m ()
 373 updateTree cId maybeListId tabType listType = do
 374   printDebug "[updateTree] cId" cId
 375   printDebug "[updateTree] maybeListId" maybeListId
 376   printDebug "[updateTree] tabType" tabType
 377   printDebug "[updateTree] listType" listType
 378   _ <- updateTree' cId maybeListId tabType listType
 379   pure ()
 380
 381 updateTree' :: FlowCmdM env err m =>
 382   CorpusId
 383   -> Maybe ListId
 384   -> TabType
 385   -> ListType
 386   -> m (ChartMetrics [MyTree])
 387 updateTree' cId maybeListId tabType listType = do
 388   listId <- case maybeListId of
 389     Just lid -> pure lid
 390     Nothing  -> defaultList cId
 391
 392   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 393   let hl = node ^. node_hyperdata
 394       treeMap = hl ^. hl_tree
 395   t <- treeData cId (ngramsTypeFromTabType tabType) listType
 396   _ <- updateHyperdata listId $ hl { _hl_tree = Map.insert tabType (ChartMetrics t) treeMap }
 397
 398   pure $ ChartMetrics t
 399
 400 getTreeHash :: FlowCmdM env err m =>
 401   CorpusId
 402   -> Maybe ListId
 403   -> TabType
 404   -> ListType
 405   -> m Text
 406 getTreeHash cId maybeListId tabType listType = do
 407   hash <$> getTree cId Nothing Nothing maybeListId tabType listType