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