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