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