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 (ngramsTypeFromTabType)
  29 import Gargantext.API.Ngrams.Types
  30 import Gargantext.API.Ngrams.NTree
  31 import Gargantext.API.Prelude (GargServer)
  32 import Gargantext.Core.Types (CorpusId, Limit, ListId, ListType(..))
  33 import Gargantext.Database.Action.Flow
  34 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataList(..))
  35 import Gargantext.Database.Admin.Types.Metrics (ChartMetrics(..), Metric(..), Metrics(..))
  36 import Gargantext.Database.Admin.Types.Node (NodeId)
  37 import Gargantext.Database.Prelude
  38 import Gargantext.Database.Query.Table.Node (defaultList, getNodeWith)
  39 import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
  40 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
  41 import Gargantext.Database.Schema.Node (node_hyperdata)
  42 import Gargantext.Prelude
  43 import Gargantext.Core.Text.Metrics (Scored(..), {-normalizeGlobal,-} normalizeLocal)
  44 import Gargantext.Core.Viz.Chart
  45 import Gargantext.Core.Viz.Types
  46 import qualified Gargantext.Database.Action.Metrics as Metrics
  47
  48 -------------------------------------------------------------
  49 -- | Scatter metrics API
  50 type ScatterAPI = Summary "SepGen IncExc metrics"
  51                   :> QueryParam  "list"       ListId
  52                   :> QueryParamR "ngramsType" TabType
  53                   :> QueryParam  "limit"      Int
  54                   :> Get '[JSON] (HashedResponse Metrics)
  55               :<|> Summary "Scatter update"
  56                   :> QueryParam  "list"       ListId
  57                   :> QueryParamR "ngramsType" TabType
  58                   :> QueryParam  "limit"      Int
  59                   :> Post '[JSON] ()
  60               :<|> "hash" :> Summary "Scatter Hash"
  61                           :> QueryParam  "list"       ListId
  62                           :> QueryParamR "ngramsType" TabType
  63                           :> Get '[JSON] Text
  64
  65 scatterApi :: NodeId -> GargServer ScatterAPI
  66 scatterApi id' = getScatter id'
  67             :<|> updateScatter id'
  68             :<|> getScatterHash id'
  69
  70 getScatter :: FlowCmdM env err m =>
  71   CorpusId
  72   -> Maybe ListId
  73   -> TabType
  74   -> Maybe Limit
  75   -> m (HashedResponse Metrics)
  76 getScatter cId maybeListId tabType _maybeLimit = do
  77   listId <- case maybeListId of
  78     Just lid -> pure lid
  79     Nothing  -> defaultList cId
  80   node <- getNodeWith listId (Proxy :: Proxy HyperdataList)
  81   let HyperdataList { _hl_scatter = mChart } = node ^. node_hyperdata
  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   _ <- updateScatter' cId maybeListId tabType maybeLimit
  98   pure ()
  99
 100 updateScatter' :: FlowCmdM env err m =>
 101   CorpusId
 102   -> Maybe ListId
 103   -> TabType
 104   -> Maybe Limit
 105   -> m Metrics
 106 updateScatter' cId maybeListId tabType maybeLimit = do
 107   (ngs', scores) <- Metrics.getMetrics cId maybeListId tabType maybeLimit
 108
 109   let
 110     metrics      = map (\(Scored t s1 s2) -> Metric t s1 s2 (listType t ngs'))
 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