src/Gargantext/Core/Text/List/Social.hs

   1 {-|
   2 Module      : Gargantext.Core.Text.List.Social
   3 Description :
   4 Copyright   : (c) CNRS, 2018-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9 -}
  10
  11 {-# LANGUAGE ScopedTypeVariables #-}
  12
  13 module Gargantext.Core.Text.List.Social
  14   where
  15
  16 import Control.Monad (mzero)
  17 import Data.Aeson
  18 import GHC.Generics
  19 import Data.HashMap.Strict (HashMap)
  20 import Data.Map (Map)
  21 import Data.Monoid (mconcat)
  22 import qualified Data.Scientific as Scientific
  23 import Data.Swagger
  24 import qualified Data.Text as T
  25 import qualified Data.Vector as V
  26 import Gargantext.API.Ngrams.Tools
  27 import Gargantext.API.Ngrams.Types
  28 import Gargantext.Core.NodeStory
  29 import Gargantext.Core.Text.List.Social.Find
  30 import Gargantext.Core.Text.List.Social.History
  31 import Gargantext.Core.Text.List.Social.Patch
  32 import Gargantext.Core.Text.List.Social.Prelude
  33 import Gargantext.Core.Types.Individu
  34 import Gargantext.Database.Admin.Types.Node
  35 import Gargantext.Database.Prelude
  36 import Gargantext.Database.Query.Table.Node.Error
  37 import Gargantext.Database.Query.Tree
  38 import Gargantext.Database.Schema.Ngrams
  39 import Gargantext.Prelude
  40 import qualified Prelude as Prelude
  41
  42 ------------------------------------------------------------------------
  43 ------------------------------------------------------------------------
  44 -- | Main parameters
  45
  46 -- | FlowSocialListPriority
  47 -- Sociological assumption: either private or others (public) first
  48 -- This parameter depends on the user choice
  49
  50 data FlowSocialListWith = FlowSocialListWithPriority { fslw_priority :: FlowSocialListPriority }
  51                         | FlowSocialListWithLists    { fslw_lists :: [ListId] }
  52   deriving (Show, Generic)
  53 instance FromJSON FlowSocialListWith where
  54   parseJSON (Object v) = do
  55     typ :: T.Text <- v .: "type"
  56     value <- v .:? "value" .!= []
  57     case typ of
  58       "MyListsFirst" -> pure $ FlowSocialListWithPriority { fslw_priority = MySelfFirst }
  59       "OtherListsFirst" -> pure $ FlowSocialListWithPriority { fslw_priority = OthersFirst }
  60       "SelectedLists" -> pure $ FlowSocialListWithLists { fslw_lists = value }
  61       _ -> pure $ FlowSocialListWithPriority { fslw_priority = MySelfFirst }
  62   parseJSON _ = mzero
  63 instance ToJSON FlowSocialListWith where
  64   toJSON (FlowSocialListWithPriority { fslw_priority = MySelfFirst }) =
  65     object [ ("type", String "MyListsFirst") ]
  66   toJSON (FlowSocialListWithPriority { fslw_priority = OthersFirst }) =
  67     object [ ("type", String "ListsFirst") ]
  68   toJSON (FlowSocialListWithLists { fslw_lists = ids }) =
  69     object [ ("type", String "SelectedLists")
  70            , ("value", Array $ V.fromList $ (map (\(NodeId id) -> Number $ Scientific.scientific (Prelude.toInteger id) 1) ids)) ]
  71 instance ToSchema FlowSocialListWith where
  72   declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
  73
  74 data FlowSocialListPriority = MySelfFirst | OthersFirst
  75   deriving (Show, Generic)
  76 instance ToSchema FlowSocialListPriority where
  77   declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
  78
  79 flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
  80 flowSocialListPriority MySelfFirst = [Private{-, Shared, Public -}]
  81 flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority MySelfFirst
  82
  83 {-
  84 -- | We keep the parents for all ngrams but terms
  85 keepAllParents :: NgramsType -> KeepAllParents
  86 keepAllParents NgramsTerms = KeepAllParents False
  87 keepAllParents _           = KeepAllParents True
  88 -}
  89
  90 ------------------------------------------------------------------------
  91 flowSocialList :: ( HasNodeStory env err m
  92                    , CmdM     env err m
  93                    , HasNodeError err
  94                    , HasTreeError err
  95                    )
  96                   => Maybe FlowSocialListWith
  97                   -> User
  98                   -> NgramsType
  99                   -> FlowCont NgramsTerm FlowListScores
 100                   -> m (FlowCont NgramsTerm FlowListScores)
 101 flowSocialList Nothing u = flowSocialList' MySelfFirst u
 102 flowSocialList (Just (FlowSocialListWithPriority p)) u = flowSocialList' p u
 103 flowSocialList (Just (FlowSocialListWithLists    ls)) _ = getHistoryScores ls History_User
 104
 105 flowSocialList' :: ( HasNodeStory env err m
 106                    , CmdM     env err m
 107                    , HasNodeError err
 108                    , HasTreeError err
 109                    )
 110                   => FlowSocialListPriority
 111                   -> User -> NgramsType
 112                   -> FlowCont NgramsTerm FlowListScores
 113                   -> m (FlowCont NgramsTerm FlowListScores)
 114 flowSocialList' flowPriority user nt flc =
 115   mconcat <$> mapM (flowSocialListByMode'   user nt flc)
 116                    (flowSocialListPriority flowPriority)
 117     where
 118
 119       flowSocialListByMode' :: ( HasNodeStory env err m
 120                                , CmdM     env err m
 121                                , HasNodeError err
 122                                , HasTreeError err
 123                                )
 124                             => User -> NgramsType
 125                             -> FlowCont NgramsTerm FlowListScores
 126                             -> NodeMode
 127                             -> m (FlowCont NgramsTerm FlowListScores)
 128       flowSocialListByMode' user' nt' flc' mode =
 129             findListsId user' mode
 130         >>= flowSocialListByModeWith nt' flc'
 131
 132
 133       flowSocialListByModeWith :: ( HasNodeStory env err m
 134                                   , CmdM     env err m
 135                                   , HasNodeError err
 136                                   , HasTreeError err
 137                                   )
 138                                => NgramsType
 139                                -> FlowCont NgramsTerm FlowListScores
 140                                -> [ListId]
 141                                -> m (FlowCont NgramsTerm FlowListScores)
 142       flowSocialListByModeWith nt'' flc'' listes =
 143         getHistoryScores listes History_User nt'' flc''
 144
 145
 146 -----------------------------------------------------------------
 147 getHistoryScores :: ( HasNodeStory env err m
 148                     , CmdM         env err m
 149                     , HasNodeError     err
 150                     , HasTreeError     err
 151                     )
 152                  => [ListId]
 153                  -> History
 154                  -> NgramsType
 155                  -> FlowCont NgramsTerm FlowListScores
 156                  -> m (FlowCont NgramsTerm FlowListScores)
 157 getHistoryScores lists hist nt fl =
 158   addScorePatches nt lists fl <$> getHistory hist nt lists
 159
 160 getHistory :: ( HasNodeStory env err m
 161               , CmdM     env err m
 162               , HasNodeError err
 163               , HasTreeError err
 164               )
 165            => History
 166            -> NgramsType
 167            -> [ListId]
 168            -> m (Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch]))
 169 getHistory hist nt listes =
 170   history hist [nt] listes  <$> getRepo' listes
 171