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 Test.QuickCheck
  38 import Web.Internal.HttpApiData (ToHttpApiData, FromHttpApiData, parseUrlPiece, toUrlPiece)
  39 import qualified Data.List       as List
  40 import qualified Data.Map.Strict as Map
  41 import qualified Data.Text       as T
  42 import qualified Data.Vector     as V
  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                         | NoList                     { makeList      :: Bool                   }
  54
  55   deriving (Eq, Show, Generic)
  56 instance FromJSON FlowSocialListWith where
  57   parseJSON (Object v) = do
  58     typ :: T.Text <- v .: "type"
  59     value <- v .:? "value" .!= []
  60     case typ of
  61       "MyListsFirst"     -> pure $ FlowSocialListWithPriority { fslw_priority = MySelfFirst }
  62       "OtherListsFirst"  -> pure $ FlowSocialListWithPriority { fslw_priority = OthersFirst }
  63       "OthersFirst"      -> pure $ FlowSocialListWithPriority { fslw_priority = OthersFirst }
  64       "SelectedLists"    -> pure $ FlowSocialListWithLists    { fslw_lists    = value       }
  65       "NoList"           -> do
  66         mkList <- v .: "makeList"
  67         pure $ NoList mkList
  68       _                  -> pure $ FlowSocialListWithPriority { fslw_priority = MySelfFirst }
  69   parseJSON _ = mzero
  70 instance ToJSON FlowSocialListWith where
  71   toJSON (FlowSocialListWithPriority { fslw_priority = MySelfFirst }) = object [ ("type", String "MyListsFirst") ]
  72   toJSON (FlowSocialListWithPriority { fslw_priority = OthersFirst }) = object [ ("type", String "OthersFirst") ]
  73   toJSON (NoList v) = object [ ("type", String "NoList"), ("makeList", toJSON v) ]
  74   toJSON (FlowSocialListWithLists { fslw_lists = ids }) =
  75     object [ ("type", String "SelectedLists")
  76            , ("value", Array $ V.fromList (map (\(NodeId id) -> toJSON id) ids)) ]
  77
  78 instance Arbitrary FlowSocialListWith where
  79   arbitrary = oneof [
  80       FlowSocialListWithPriority <$> arbitrary
  81     , FlowSocialListWithLists <$> arbitrary
  82     , NoList <$> arbitrary
  83     ]
  84
  85 instance ToSchema FlowSocialListWith where
  86   declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
  87 instance FromHttpApiData FlowSocialListWith
  88   where
  89     parseUrlPiece "My lists first"    = pure $ FlowSocialListWithPriority { fslw_priority = MySelfFirst }
  90     parseUrlPiece "Others lists first" = pure $ FlowSocialListWithPriority { fslw_priority = OthersFirst }
  91     parseUrlPiece "NoList"          = pure $ NoList True
  92     parseUrlPiece x                 = panic $ "[G.C.T.L.Social] TODO FromHttpApiData FlowSocialListWith error: " <> (cs $ show x)
  93
  94 instance ToHttpApiData   FlowSocialListWith where
  95     toUrlPiece (FlowSocialListWithPriority  MySelfFirst) = "MySelfFirst"
  96     toUrlPiece (FlowSocialListWithPriority  OthersFirst) = "OtherListsFirst"
  97     toUrlPiece (NoList _) = "NoList"
  98     toUrlPiece (FlowSocialListWithLists _)  = panic "[G.C.T.L.Social] TODO ToHttpApiData FlowSocialListWith"
  99
 100 data FlowSocialListPriority = MySelfFirst | OthersFirst
 101   deriving (Eq, Show, Generic, Enum, Bounded)
 102 instance ToSchema FlowSocialListPriority where
 103   declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
 104
 105 instance Arbitrary FlowSocialListPriority where
 106   arbitrary = arbitraryBoundedEnum
 107
 108 flowSocialListPriority :: FlowSocialListPriority -> [NodeMode]
 109 flowSocialListPriority MySelfFirst = [Private{-, Shared, Public -}]
 110 flowSocialListPriority OthersFirst = reverse $ flowSocialListPriority MySelfFirst
 111 {-
 112 -- | We keep the parents for all ngrams but terms
 113 keepAllParents :: NgramsType -> KeepAllParents
 114 keepAllParents NgramsTerms = KeepAllParents False
 115 keepAllParents _           = KeepAllParents True
 116 -}
 117
 118 ------------------------------------------------------------------------
 119 flowSocialList :: ( HasNodeStory env err m
 120                    , CmdM     env err m
 121                    , HasNodeError err
 122                    , HasTreeError err
 123                    )
 124                   => Maybe FlowSocialListWith
 125                   -> User
 126                   -> NgramsType
 127                   -> FlowCont NgramsTerm FlowListScores
 128                   -> m (FlowCont NgramsTerm FlowListScores)
 129 flowSocialList Nothing u = flowSocialList' MySelfFirst u
 130 flowSocialList (Just (FlowSocialListWithPriority p))  u = flowSocialList' p u
 131 flowSocialList (Just (FlowSocialListWithLists    ls)) _ = getHistoryScores ls
 132 flowSocialList (Just (NoList _))                     _u = panic "[G.C.T.L.Social] Should not be executed"
 133
 134 flowSocialList' :: ( HasNodeStory env err m
 135                    , CmdM     env err m
 136                    , HasNodeError err
 137                    , HasTreeError err
 138                    )
 139                   => FlowSocialListPriority
 140                   -> User -> NgramsType
 141                   -> FlowCont NgramsTerm FlowListScores
 142                   -> m (FlowCont NgramsTerm FlowListScores)
 143 flowSocialList' flowPriority user nt flc =
 144   mconcat <$> mapM (flowSocialListByMode'   user nt flc)
 145                    (flowSocialListPriority flowPriority)
 146     where
 147
 148       flowSocialListByMode' :: ( HasNodeStory env err m
 149                                , CmdM     env err m
 150                                , HasNodeError err
 151                                , HasTreeError err
 152                                )
 153                             => User -> NgramsType
 154                             -> FlowCont NgramsTerm FlowListScores
 155                             -> NodeMode
 156                             -> m (FlowCont NgramsTerm FlowListScores)
 157       flowSocialListByMode' user' nt' flc' mode =
 158             findListsId user' mode
 159         >>= flowSocialListByModeWith nt' flc'
 160
 161
 162       flowSocialListByModeWith :: ( HasNodeStory env err m
 163                                   , CmdM     env err m
 164                                   , HasNodeError err
 165                                   , HasTreeError err
 166                                   )
 167                                => NgramsType
 168                                -> FlowCont NgramsTerm FlowListScores
 169                                -> [ListId]
 170                                -> m (FlowCont NgramsTerm FlowListScores)
 171       flowSocialListByModeWith nt'' flc'' listes =
 172         getHistoryScores listes nt'' flc''
 173
 174
 175 -----------------------------------------------------------------
 176 getHistoryScores :: ( HasNodeStory env err m
 177                     , CmdM         env err m
 178                     , HasNodeError     err
 179                     , HasTreeError     err
 180                     )
 181                  => [ListId]
 182                  -> NgramsType
 183                  -> FlowCont NgramsTerm FlowListScores
 184                  -> m (FlowCont NgramsTerm FlowListScores)
 185 getHistoryScores lists nt fl =
 186   addScorePatches nt lists fl <$> getHistory [nt] lists
 187
 188
 189 getHistory :: ( HasNodeStory env err m
 190               , CmdM     env err m
 191               , HasNodeError err
 192               , HasTreeError err
 193               )
 194          => [NgramsType]
 195          -> [ListId]
 196          -> m (Map ListId (Map NgramsType [HashMap NgramsTerm NgramsPatch]))
 197 getHistory types listsId = do
 198   pool <- view connPool
 199   nsp  <- liftBase $ withResource pool $ \c -> getNodesArchiveHistory c listsId
 200   pure $ Map.map (Map.filterWithKey (\k _ -> List.elem k types))
 201        $ Map.filterWithKey (\k _ -> List.elem k listsId)
 202        $ Map.fromListWith (Map.unionWith (<>)) nsp