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