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.Time (UTCTime)
  24 import Data.Text (Text)
  25 import Servant
  26
  27 import Gargantext.API.HashedResponse
  28 import Gargantext.API.Ngrams
  29 import Gargantext.API.Ngrams.NTree
  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(..))
  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 = mChart } = node ^. node_hyperdata
  81
  82   chart <- case mChart of
  83     Just chart -> pure chart
  84     Nothing    -> do
  85       updateScatter' cId maybeListId tabType Nothing
  86
  87   pure $ constructHashedResponse chart
  88
  89 updateScatter :: FlowCmdM env err m =>
  90   CorpusId
  91   -> Maybe ListId
  92   -> TabType
  93   -> Maybe Limit
  94   -> m ()
  95 updateScatter cId maybeListId tabType maybeLimit = do
  96   _ <- updateScatter' cId maybeListId tabType maybeLimit
  97   pure ()
  98
  99 updateScatter' :: FlowCmdM env err m =>
 100   CorpusId
 101   -> Maybe ListId
 102   -> TabType
 103   -> Maybe Limit
 104   -> m Metrics
 105 updateScatter' cId maybeListId tabType maybeLimit = do
 106   (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
 107
 108   let
 109     metrics      = map (\(Scored t s1 s2) -> Metric t s1 s2 (listType t ngs'))
 110                  -- $ normalizeGlobal
 111                  $ map normalizeLocal scores
 112     listType t m = maybe (panic errorMsg) fst $ Map.lookup t m
 113     errorMsg     = "API.Node.metrics: key absent"
 114
 115   listId <- case maybeListId of
 116     Just lid -> pure lid
 117     Nothing  -> defaultList cId
 118   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 119   let hl = node ^. node_hyperdata
 120   _ <- updateHyperdata listId $ hl { _hl_scatter = Just $ Metrics metrics }
 121
 122   pure $ Metrics metrics
 123
 124 getScatterHash :: FlowCmdM env err m =>
 125   CorpusId
 126   -> Maybe ListId
 127   -> TabType
 128   -> m Text
 129 getScatterHash cId maybeListId tabType = do
 130   hash <$> getScatter cId maybeListId tabType Nothing
 131
 132
 133 -------------------------------------------------------------
 134 -- | Chart metrics API
 135 type ChartApi = Summary " Chart API"
 136               :> QueryParam "from" UTCTime
 137               :> QueryParam "to"   UTCTime
 138               :> QueryParam  "list"       ListId
 139               :> QueryParamR "ngramsType" TabType
 140               :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
 141             :<|> Summary "Chart update"
 142                :> QueryParam  "list"       ListId
 143                :> QueryParamR "ngramsType" TabType
 144                :> QueryParam  "limit"      Int
 145                :> Post '[JSON] ()
 146             :<|> "hash" :> Summary "Chart Hash"
 147                :> QueryParam  "list"       ListId
 148                :> QueryParamR "ngramsType" TabType
 149                :> Get '[JSON] Text
 150
 151 chartApi :: NodeId -> GargServer ChartApi
 152 chartApi id' = getChart id'
 153           :<|> updateChart id'
 154           :<|> getChartHash id'
 155
 156 -- TODO add start / end
 157 getChart :: FlowCmdM env err m =>
 158             CorpusId
 159          -> Maybe UTCTime
 160          -> Maybe UTCTime
 161          -> Maybe ListId
 162          -> TabType
 163          -> m (HashedResponse (ChartMetrics Histo))
 164 getChart cId _start _end maybeListId tabType = do
 165   listId <- case maybeListId of
 166     Just lid -> pure lid
 167     Nothing  -> defaultList cId
 168   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 169   let HyperdataList { _hl_chart = mChart } = node ^. node_hyperdata
 170
 171   chart <- case mChart of
 172     Just chart -> pure chart
 173     Nothing    -> do
 174       updateChart' cId maybeListId tabType Nothing
 175
 176   pure $ constructHashedResponse chart
 177
 178 updateChart :: HasNodeError err =>
 179   CorpusId
 180   -> Maybe ListId
 181   -> TabType
 182   -> Maybe Limit
 183   -> Cmd err ()
 184 updateChart cId maybeListId tabType maybeLimit = do
 185   _ <- updateChart' cId maybeListId tabType maybeLimit
 186   pure ()
 187
 188 updateChart' :: HasNodeError err =>
 189   CorpusId
 190   -> Maybe ListId
 191   -> TabType
 192   -> Maybe Limit
 193   -> Cmd err (ChartMetrics Histo)
 194 updateChart' cId maybeListId _tabType _maybeLimit = do
 195   listId <- case maybeListId of
 196     Just lid -> pure lid
 197     Nothing  -> defaultList cId
 198   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 199   let hl = node ^. node_hyperdata
 200   h <- histoData cId
 201   _ <- updateHyperdata listId $ hl { _hl_chart = Just $ ChartMetrics h }
 202
 203   pure $ ChartMetrics h
 204
 205
 206 getChartHash :: FlowCmdM env err m =>
 207   CorpusId
 208   -> Maybe ListId
 209   -> TabType
 210   -> m Text
 211 getChartHash cId maybeListId tabType = do
 212   hash <$> getChart cId Nothing Nothing maybeListId tabType
 213
 214 -------------------------------------------------------------
 215 -- | Pie metrics API
 216 type PieApi = Summary "Pie Chart"
 217            :> QueryParam "from" UTCTime
 218            :> QueryParam "to"   UTCTime
 219            :> QueryParam  "list"       ListId
 220            :> QueryParamR "ngramsType" TabType
 221            :> Get '[JSON] (HashedResponse (ChartMetrics Histo))
 222          :<|> Summary "Pie Chart update"
 223              :> QueryParam  "list"       ListId
 224              :> QueryParamR "ngramsType" TabType
 225              :> QueryParam  "limit"      Int
 226              :> Post '[JSON] ()
 227          :<|> "hash" :> Summary "Pie Hash"
 228                      :> QueryParam  "list"       ListId
 229                      :> QueryParamR "ngramsType" TabType
 230                      :> Get '[JSON] Text
 231
 232 pieApi :: NodeId -> GargServer PieApi
 233 pieApi id' = getPie id'
 234         :<|> updatePie id'
 235         :<|> getPieHash id'
 236
 237 getPie :: FlowCmdM env err m
 238        => CorpusId
 239        -> Maybe UTCTime
 240        -> Maybe UTCTime
 241        -> Maybe ListId
 242        -> TabType
 243        -> m (HashedResponse (ChartMetrics Histo))
 244 getPie cId _start _end maybeListId tabType = do
 245   listId <- case maybeListId of
 246     Just lid -> pure lid
 247     Nothing  -> defaultList cId
 248   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 249   let HyperdataList { _hl_pie = mChart } = node ^. node_hyperdata
 250
 251   chart <- case mChart of
 252     Just chart -> pure chart
 253     Nothing    -> do
 254       updatePie' cId maybeListId tabType Nothing
 255
 256   pure $ constructHashedResponse chart
 257
 258 updatePie :: FlowCmdM env err m =>
 259   CorpusId
 260   -> Maybe ListId
 261   -> TabType
 262   -> Maybe Limit
 263   -> m ()
 264 updatePie cId maybeListId tabType maybeLimit = do
 265   _ <- updatePie' cId maybeListId tabType maybeLimit
 266   pure ()
 267
 268 updatePie' :: FlowCmdM env err m =>
 269   CorpusId
 270   -> Maybe ListId
 271   -> TabType
 272   -> Maybe Limit
 273   -> m (ChartMetrics Histo)
 274 updatePie' cId maybeListId tabType _maybeLimit = do
 275   listId <- case maybeListId of
 276     Just lid -> pure lid
 277     Nothing  -> defaultList cId
 278   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 279   let hl = node ^. node_hyperdata
 280
 281   p <- chartData cId (ngramsTypeFromTabType tabType) MapTerm
 282   _ <- updateHyperdata listId $ hl { _hl_pie = Just $ ChartMetrics p }
 283
 284   pure $ ChartMetrics p
 285
 286 getPieHash :: FlowCmdM env err m =>
 287   CorpusId
 288   -> Maybe ListId
 289   -> TabType
 290   -> m Text
 291 getPieHash cId maybeListId tabType = do
 292   hash <$> getPie cId Nothing Nothing maybeListId tabType
 293
 294 -------------------------------------------------------------
 295 -- | Tree metrics API
 296
 297 type TreeApi = Summary " Tree API"
 298            :> QueryParam "from" UTCTime
 299            :> QueryParam "to"   UTCTime
 300            :> QueryParam  "list"       ListId
 301            :> QueryParamR "ngramsType" TabType
 302            :> QueryParamR "listType"   ListType
 303            :> Get '[JSON] (HashedResponse (ChartMetrics [MyTree]))
 304         :<|> Summary "Tree Chart update"
 305                 :> QueryParam  "list"       ListId
 306                 :> QueryParamR "ngramsType" TabType
 307                 :> QueryParamR "listType"   ListType
 308                 :> Post '[JSON] ()
 309           :<|> "hash" :>
 310                   Summary "Tree Hash"
 311               :> QueryParam  "list"       ListId
 312               :> QueryParamR "ngramsType" TabType
 313               :> QueryParamR "listType"   ListType
 314               :> Get '[JSON] Text
 315
 316                 -- Depending on the Type of the Node, we could post
 317                 -- New documents for a corpus
 318                 -- New map list terms
 319              -- :<|> "process"  :> MultipartForm MultipartData :> Post '[JSON] Text
 320
 321 treeApi :: NodeId -> GargServer TreeApi
 322 treeApi id' = getTree id'
 323          :<|> updateTree id'
 324          :<|> getTreeHash id'
 325
 326 getTree :: FlowCmdM env err m
 327         => CorpusId
 328         -> Maybe UTCTime
 329         -> Maybe UTCTime
 330         -> Maybe ListId
 331         -> TabType
 332         -> ListType
 333         -> m (HashedResponse (ChartMetrics [MyTree]))
 334 getTree cId _start _end maybeListId tabType listType = do
 335   listId <- case maybeListId of
 336     Just lid -> pure lid
 337     Nothing  -> defaultList cId
 338
 339   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 340   let HyperdataList { _hl_tree = mChart } = node ^. node_hyperdata
 341
 342   chart <- case mChart of
 343     Just chart -> pure chart
 344     Nothing    -> do
 345       updateTree' cId maybeListId tabType listType
 346
 347   pure $ constructHashedResponse chart
 348
 349 updateTree :: FlowCmdM env err m =>
 350   CorpusId
 351   -> Maybe ListId
 352   -> TabType
 353   -> ListType
 354   -> m ()
 355 updateTree cId maybeListId tabType listType = do
 356   _ <- updateTree' cId maybeListId tabType listType
 357   pure ()
 358
 359 updateTree' :: FlowCmdM env err m =>
 360   CorpusId
 361   -> Maybe ListId
 362   -> TabType
 363   -> ListType
 364   -> m (ChartMetrics [MyTree])
 365 updateTree' cId maybeListId tabType listType = do
 366   listId <- case maybeListId of
 367     Just lid -> pure lid
 368     Nothing  -> defaultList cId
 369
 370   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
 371   let hl = node ^. node_hyperdata
 372   t <- treeData cId (ngramsTypeFromTabType tabType) listType
 373   _ <- updateHyperdata listId $ hl { _hl_tree = Just $ ChartMetrics t }
 374
 375   pure $ ChartMetrics t
 376
 377 getTreeHash :: FlowCmdM env err m =>
 378   CorpusId
 379   -> Maybe ListId
 380   -> TabType
 381   -> ListType
 382   -> m Text
 383 getTreeHash cId maybeListId tabType listType = do
 384   hash <$> getTree cId Nothing Nothing maybeListId tabType listType