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