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