src/Gargantext/API/Ngrams.hs

   1 {-|
   2 Module      : Gargantext.API.Ngrams
   3 Description : Server API
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Ngrams API
  11
  12 -- | TODO
  13 get ngrams filtered by NgramsType
  14 add get
  15
  16 -}
  17
  18 {-# LANGUAGE DataKinds         #-}
  19 {-# LANGUAGE DeriveGeneric     #-}
  20 {-# LANGUAGE NoImplicitPrelude #-}
  21 {-# LANGUAGE OverloadedStrings #-}
  22 {-# LANGUAGE ScopedTypeVariables #-}
  23 {-# LANGUAGE TemplateHaskell   #-}
  24 {-# LANGUAGE TypeOperators     #-}
  25 {-# LANGUAGE FlexibleInstances #-}
  26 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  27 {-# LANGUAGE RankNTypes        #-}
  28 {-# OPTIONS -fno-warn-orphans #-}
  29
  30 module Gargantext.API.Ngrams
  31   where
  32
  33 import Prelude (round)
  34 -- import Gargantext.Database.Schema.User  (UserId)
  35 import Data.Functor (($>))
  36 import Data.Patch.Class (Replace, replace, new)
  37 --import qualified Data.Map.Strict.Patch as PM
  38 import Data.Monoid
  39 --import Data.Semigroup
  40 import Data.Set (Set)
  41 import qualified Data.Set as Set
  42 import Data.Maybe (isJust)
  43 import Data.Tuple.Extra (first)
  44 -- import qualified Data.Map.Strict as DM
  45 import Data.Map.Strict (Map, mapKeys, fromListWith)
  46 --import qualified Data.Set as Set
  47 import Control.Lens (makeLenses, Prism', prism', (^..), (.~), (#), to, withIndex, folded, ifolded)
  48 import Control.Monad (guard)
  49 import Control.Monad.Error.Class (MonadError, throwError)
  50 import Data.Aeson
  51 import Data.Aeson.TH (deriveJSON)
  52 import Data.Either(Either(Left))
  53 import Data.Map (lookup)
  54 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
  55 import Data.Swagger hiding (version, patch)
  56 import Data.Text (Text)
  57 import GHC.Generics (Generic)
  58 import Gargantext.Core.Utils.Prefix (unPrefix)
  59 import Gargantext.Database.Types.Node (NodeType(..))
  60 import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
  61 import Gargantext.Database.Schema.Ngrams (NgramsType, NgramsTypeId, ngramsTypeId, NgramsTableData(..))
  62 import qualified Gargantext.Database.Schema.Ngrams as Ngrams
  63 import Gargantext.Database.Schema.NodeNgram
  64 import Gargantext.Database.Utils (Cmd)
  65 import Gargantext.Prelude
  66 import Gargantext.Core.Types (ListType(..), ListTypeId, ListId, CorpusId, Limit, Offset, listTypeId)
  67 import Prelude (Enum, Bounded, minBound, maxBound)
  68 import Servant hiding (Patch)
  69 import Test.QuickCheck (elements)
  70 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  71
  72 ------------------------------------------------------------------------
  73 --data FacetFormat = Table | Chart
  74 data TabType   = Docs     | Terms  | Sources | Authors | Institutes | Trash
  75                | Contacts
  76   deriving (Generic, Enum, Bounded)
  77
  78 instance FromHttpApiData TabType
  79   where
  80     parseUrlPiece "Docs"       = pure Docs
  81     parseUrlPiece "Terms"      = pure Terms
  82     parseUrlPiece "Sources"    = pure Sources
  83     parseUrlPiece "Institutes" = pure Institutes
  84     parseUrlPiece "Authors"    = pure Authors
  85     parseUrlPiece "Trash"      = pure Trash
  86
  87     parseUrlPiece "Contacts"   = pure Contacts
  88
  89     parseUrlPiece _            = Left "Unexpected value of TabType"
  90
  91 instance ToParamSchema   TabType
  92 instance ToJSON    TabType
  93 instance FromJSON  TabType
  94 instance ToSchema  TabType
  95 instance Arbitrary TabType
  96   where
  97     arbitrary = elements [minBound .. maxBound]
  98
  99 ------------------------------------------------------------------------
 100 type NgramsTerm = Text
 101
 102 data NgramsElement =
 103      NgramsElement { _ne_ngrams      :: NgramsTerm
 104                    , _ne_list        :: ListType
 105                    , _ne_occurrences :: Int
 106                    , _ne_parent      :: Maybe NgramsTerm
 107                    , _ne_children    :: Set NgramsTerm
 108                    }
 109       deriving (Ord, Eq, Show, Generic)
 110
 111 deriveJSON (unPrefix "_ne_") ''NgramsElement
 112 makeLenses ''NgramsElement
 113
 114 instance ToSchema NgramsElement
 115 instance Arbitrary NgramsElement where
 116   arbitrary = elements [NgramsElement "sport" GraphList 1 Nothing mempty]
 117
 118 ------------------------------------------------------------------------
 119 newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
 120   deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
 121
 122 -- | TODO Check N and Weight
 123 toNgramsElement :: [NgramsTableData] -> [NgramsElement]
 124 toNgramsElement ns = map toNgramsElement' ns
 125     where
 126       toNgramsElement' (NgramsTableData _ p t _ lt w) = NgramsElement t lt' (round w) p' c'
 127         where
 128           p' = case p of
 129                  Nothing -> Nothing
 130                  Just x  -> lookup x mapParent
 131           c' = maybe mempty identity $ lookup t mapChildren
 132           lt' = maybe (panic "API.Ngrams: listypeId") identity lt
 133
 134       mapParent :: Map Int Text
 135       mapParent   = fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
 136
 137       mapChildren :: Map Text (Set Text)
 138       mapChildren = mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
 139                   $ fromListWith (<>)
 140                   $ map (first fromJust)
 141                   $ filter (isJust . fst)
 142                   $ map (\(NgramsTableData _ p t _ _ _) -> (p, Set.singleton t)) ns
 143
 144
 145 instance Arbitrary NgramsTable where
 146   arbitrary = elements
 147               [ NgramsTable
 148                 [ NgramsElement "animal"  GraphList     1  Nothing       (Set.fromList ["dog", "cat"])
 149                 , NgramsElement "cat"     GraphList     1 (Just "animal") mempty
 150                 , NgramsElement "cats"    StopList      4  Nothing        mempty
 151                 , NgramsElement "dog"     GraphList     3 (Just "animal")(Set.fromList ["dogs"])
 152                 , NgramsElement "dogs"    StopList      4 (Just "dog")    mempty
 153                 , NgramsElement "fox"     GraphList     1  Nothing        mempty
 154                 , NgramsElement "object"  CandidateList 2  Nothing        mempty
 155                 , NgramsElement "nothing" StopList      4  Nothing        mempty
 156                 , NgramsElement "organic" GraphList     3  Nothing        (Set.singleton "flower")
 157                 , NgramsElement "flower"  GraphList     3 (Just "organic") mempty
 158                 , NgramsElement "moon"    CandidateList 1  Nothing         mempty
 159                 , NgramsElement "sky"     StopList      1  Nothing         mempty
 160                 ]
 161               ]
 162 instance ToSchema NgramsTable
 163
 164 ------------------------------------------------------------------------
 165 -- On the Client side:
 166 --data Action = InGroup     NgramsId NgramsId
 167 --            | OutGroup    NgramsId NgramsId
 168 --            | SetListType NgramsId ListType
 169
 170 data PatchSet a = PatchSet
 171   { _rem :: Set a
 172   , _add :: Set a
 173   }
 174   deriving (Eq, Ord, Show, Generic)
 175
 176 instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
 177   arbitrary = PatchSet <$> arbitrary <*> arbitrary
 178
 179 instance ToJSON a => ToJSON (PatchSet a) where
 180   toJSON     = genericToJSON     $ unPrefix "_"
 181   toEncoding = genericToEncoding $ unPrefix "_"
 182
 183 instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
 184   parseJSON = genericParseJSON $ unPrefix "_"
 185
 186 instance ToSchema a => ToSchema (PatchSet a)
 187
 188 instance ToSchema a => ToSchema (Replace a) where
 189   declareNamedSchema (_ :: proxy (Replace a)) = do
 190     -- TODO Keep constructor is not supported here.
 191     aSchema <- declareSchemaRef (Proxy :: Proxy a)
 192     return $ NamedSchema (Just "Replace") $ mempty
 193       & type_ .~ SwaggerObject
 194       & properties .~
 195           InsOrdHashMap.fromList
 196           [ ("old", aSchema)
 197           , ("new", aSchema)
 198           ]
 199       & required .~ [ "old", "new" ]
 200
 201 data NgramsPatch =
 202      NgramsPatch { _patch_children :: PatchSet NgramsTerm
 203                  , _patch_list     :: Replace ListType   -- TODO Map UserId ListType
 204                  }
 205       deriving (Ord, Eq, Show, Generic)
 206 deriveJSON (unPrefix "_") ''NgramsPatch
 207 makeLenses ''NgramsPatch
 208
 209 -- instance Semigroup NgramsPatch where
 210
 211 instance ToSchema  NgramsPatch
 212
 213 instance Arbitrary NgramsPatch where
 214   arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
 215
 216 newtype NgramsTablePatch =
 217      NgramsTablePatch { _ntp_ngrams_patches :: Map NgramsTerm NgramsPatch }
 218       deriving (Ord, Eq, Show, Generic, Arbitrary, ToJSON, FromJSON)
 219 makeLenses ''NgramsTablePatch
 220 instance ToSchema  NgramsTablePatch
 221
 222 -- TODO: replace by mempty once we have the Monoid instance
 223 emptyNgramsTablePatch :: NgramsTablePatch
 224 emptyNgramsTablePatch = NgramsTablePatch mempty
 225
 226 ------------------------------------------------------------------------
 227 ------------------------------------------------------------------------
 228 type Version = Int
 229
 230 data Versioned a = Versioned
 231   { _v_version :: Version
 232   , _v_data    :: a
 233   }
 234   deriving (Generic)
 235 deriveJSON (unPrefix "_v_") ''Versioned
 236 makeLenses ''Versioned
 237 instance ToSchema a => ToSchema (Versioned a)
 238 instance Arbitrary a => Arbitrary (Versioned a) where
 239   arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
 240
 241 {-
 242 -- TODO sequencs of modifications (Patchs)
 243 type NgramsIdPatch = Patch NgramsId NgramsPatch
 244
 245 ngramsPatch :: Int -> NgramsPatch
 246 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopList)]) (Set.fromList [n]) Set.empty
 247
 248 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
 249 toEdit n p = Edit n p
 250 ngramsIdPatch :: Patch NgramsId NgramsPatch
 251 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
 252                                        , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
 253                                        , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
 254                                        ]
 255
 256 -- applyPatchBack :: Patch -> IO Patch
 257 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
 258 -}
 259 ------------------------------------------------------------------------
 260 ------------------------------------------------------------------------
 261 ------------------------------------------------------------------------
 262
 263 type TableNgramsApiGet = Summary " Table Ngrams API Get"
 264                       :> QueryParam "ngramsType"   TabType
 265                       :> QueryParam "list"   ListId
 266                       :> QueryParam "limit"  Limit
 267                       :> QueryParam "offset" Offset
 268                       :> Get    '[JSON] (Versioned NgramsTable)
 269
 270 type TableNgramsApi = Summary " Table Ngrams API Change"
 271                       :> QueryParam "ngramsType"   TabType
 272                       :> QueryParam "list"   ListId
 273                       :> ReqBody '[JSON] (Versioned NgramsTablePatch)
 274                       :> Put     '[JSON] (Versioned NgramsTablePatch)
 275
 276 data NgramError = UnsupportedVersion
 277   deriving (Show)
 278
 279 class HasNgramError e where
 280   _NgramError :: Prism' e NgramError
 281
 282 instance HasNgramError ServantErr where
 283   _NgramError = prism' make match
 284     where
 285       err = err500 { errBody = "NgramError: Unsupported version" }
 286       make UnsupportedVersion = err
 287       match e = guard (e == err) $> UnsupportedVersion
 288
 289 ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
 290 ngramError nne = throwError $ _NgramError # nne
 291
 292 -- TODO: Replace.old is ignored which means that if the current list
 293 -- `GraphList` and that the patch is `Replace CandidateList StopList` then
 294 -- the list is going to be `StopList` while it should keep `GraphList`.
 295 -- However this should not happen in non conflicting situations.
 296 mkListsUpdate :: NgramsType -> NgramsTablePatch -> [(NgramsTypeId, NgramsTerm, ListTypeId)]
 297 mkListsUpdate nt patches =
 298   [ (ngramsTypeId nt, ng, listTypeId lt)
 299   | (ng, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
 300   , lt <- patch ^.. patch_list . new
 301   ]
 302
 303 mkChildrenGroups :: (PatchSet NgramsTerm -> Set NgramsTerm)
 304                  -> NgramsType
 305                  -> NgramsTablePatch
 306                  -> [(NgramsTypeId, NgramsParent, NgramsChild)]
 307 mkChildrenGroups addOrRem nt patches =
 308   [ (ngramsTypeId nt, parent, child)
 309   | (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
 310   , child <- patch ^.. patch_children . to addOrRem . folded
 311   ]
 312
 313 ngramsTypeFromTabType :: Maybe TabType -> NgramsType
 314 ngramsTypeFromTabType maybeTabType =
 315   let lieu = "Garg.API.Ngrams: " :: Text in
 316     case maybeTabType of
 317           Nothing  -> panic (lieu <> "Indicate the Table")
 318           Just tab -> case tab of
 319               Sources    -> Ngrams.Sources
 320               Authors    -> Ngrams.Authors
 321               Institutes -> Ngrams.Institutes
 322               Terms      -> Ngrams.NgramsTerms
 323               _          -> panic $ lieu <> "No Ngrams for this tab"
 324
 325
 326 -- Apply the given patch to the DB and returns the patch to be applied on the
 327 -- cilent.
 328 -- TODO:
 329 -- In this perliminary version the OT aspect is missing, therefore the version
 330 -- number is always 1 and the returned patch is always empty.
 331 tableNgramsPatch :: (HasNgramError err, HasNodeError err)
 332                  => CorpusId -> Maybe TabType -> Maybe ListId
 333                  -> Versioned NgramsTablePatch
 334                  -> Cmd err (Versioned NgramsTablePatch)
 335 tableNgramsPatch corpusId maybeTabType maybeList (Versioned version patch) = do
 336   when (version /= 1) $ ngramError UnsupportedVersion
 337   let ngramsType = ngramsTypeFromTabType maybeTabType
 338   listId <- maybe (defaultList corpusId) pure maybeList
 339   updateNodeNgrams $ NodeNgramsUpdate
 340     { _nnu_user_list_id = listId
 341     , _nnu_lists_update = mkListsUpdate ngramsType patch
 342     , _nnu_rem_children = mkChildrenGroups _rem ngramsType patch
 343     , _nnu_add_children = mkChildrenGroups _add ngramsType patch
 344     }
 345   pure $ Versioned 1 emptyNgramsTablePatch
 346
 347 -- | TODO Errors management
 348 --  TODO: polymorphic for Annuaire or Corpus or ...
 349 getTableNgrams :: HasNodeError err
 350                => CorpusId -> Maybe TabType
 351                -> Maybe ListId -> Maybe Limit -> Maybe Offset
 352                -> Cmd err (Versioned NgramsTable)
 353 getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
 354   let ngramsType = ngramsTypeFromTabType maybeTabType
 355   listId <- maybe (defaultList cId) pure maybeListId
 356
 357   let
 358     defaultLimit = 10 -- TODO
 359     limit_  = maybe defaultLimit identity mlimit
 360     offset_ = maybe 0 identity moffset
 361
 362   ngramsTableDatas <-
 363     Ngrams.getNgramsTableDb NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
 364
 365   -- printDebug "ngramsTableDatas" ngramsTableDatas
 366
 367   pure $ Versioned 1 $ NgramsTable (toNgramsElement ngramsTableDatas)