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     -- TODO Keep constructor is not supported here.
 167     aSchema <- declareSchemaRef (Proxy :: Proxy a)
 168     return $ NamedSchema (Just "Replace") $ mempty
 169       & type_ .~ SwaggerObject
 170       & properties .~
 171           InsOrdHashMap.fromList
 172           [ ("old", aSchema)
 173           , ("new", aSchema)
 174           ]
 175       & required .~ [ "old", "new" ]
 176
 177 data NgramsPatch =
 178      NgramsPatch { _patch_children :: PatchSet NgramsTerm
 179                  , _patch_list     :: Replace ListType   -- TODO Map UserId ListType
 180                  }
 181       deriving (Ord, Eq, Show, Generic)
 182 deriveJSON (unPrefix "_") ''NgramsPatch
 183 makeLenses ''NgramsPatch
 184
 185 -- instance Semigroup NgramsPatch where
 186
 187 instance ToSchema  NgramsPatch
 188
 189 instance Arbitrary NgramsPatch where
 190   arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
 191
 192 newtype NgramsTablePatch =
 193      NgramsTablePatch { _ntp_ngrams_patches :: Map NgramsTerm NgramsPatch }
 194       deriving (Ord, Eq, Show, Generic, Arbitrary, ToJSON, FromJSON)
 195 makeLenses ''NgramsTablePatch
 196 instance ToSchema  NgramsTablePatch
 197
 198 -- TODO: replace by mempty once we have the Monoid instance
 199 emptyNgramsTablePatch :: NgramsTablePatch
 200 emptyNgramsTablePatch = NgramsTablePatch mempty
 201
 202 ------------------------------------------------------------------------
 203 ------------------------------------------------------------------------
 204 type Version = Int
 205
 206 data Versioned a = Versioned
 207   { _v_version :: Version
 208   , _v_data    :: a
 209   }
 210   deriving (Generic)
 211 deriveJSON (unPrefix "_v_") ''Versioned
 212 makeLenses ''Versioned
 213 instance ToSchema a => ToSchema (Versioned a)
 214 instance Arbitrary a => Arbitrary (Versioned a) where
 215   arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
 216
 217 {-
 218 -- TODO sequencs of modifications (Patchs)
 219 type NgramsIdPatch = Patch NgramsId NgramsPatch
 220
 221 ngramsPatch :: Int -> NgramsPatch
 222 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopList)]) (Set.fromList [n]) Set.empty
 223
 224 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
 225 toEdit n p = Edit n p
 226 ngramsIdPatch :: Patch NgramsId NgramsPatch
 227 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
 228                                        , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
 229                                        , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
 230                                        ]
 231
 232 -- applyPatchBack :: Patch -> IO Patch
 233 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
 234 -}
 235 ------------------------------------------------------------------------
 236 ------------------------------------------------------------------------
 237 ------------------------------------------------------------------------
 238
 239 type TableNgramsApiGet = Summary " Table Ngrams API Get"
 240                       :> QueryParam "ngramsType"   TabType
 241                       :> QueryParam "list"   ListId
 242                       :> QueryParam "limit"  Limit
 243                       :> QueryParam "offset" Offset
 244                       :> Get    '[JSON] (Versioned NgramsTable)
 245
 246 type TableNgramsApi = Summary " Table Ngrams API Change"
 247                       :> QueryParam "list"   ListId
 248                       :> ReqBody '[JSON] (Versioned NgramsTablePatch)
 249                       :> Put     '[JSON] (Versioned NgramsTablePatch)
 250
 251 data NgramError = UnsupportedVersion
 252   deriving (Show)
 253
 254 class HasNgramError e where
 255   _NgramError :: Prism' e NgramError
 256
 257 instance HasNgramError ServantErr where
 258   _NgramError = prism' make match
 259     where
 260       err = err500 { errBody = "NgramError: Unsupported version" }
 261       make UnsupportedVersion = err
 262       match e = guard (e == err) $> UnsupportedVersion
 263
 264 ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
 265 ngramError nne = throwError $ _NgramError # nne
 266
 267 -- TODO: Replace.old is ignored which means that if the current list
 268 -- `GraphList` and that the patch is `Replace CandidateList StopList` then
 269 -- the list is going to be `StopList` while it should keep `GraphList`.
 270 -- However this should not happen in non conflicting situations.
 271 mkListsUpdate :: ListId -> NgramsTablePatch -> [(ListId, NgramsTerm, ListTypeId)]
 272 mkListsUpdate lId patches =
 273   [ (lId, ng, listTypeId lt)
 274   | (ng, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
 275   , lt <- patch ^.. patch_list . new
 276   ]
 277
 278 mkChildrenGroups :: ListId
 279                  -> (PatchSet NgramsTerm -> Set NgramsTerm)
 280                  -> NgramsTablePatch
 281                  -> [(ListId, NgramsParent, NgramsChild, Maybe Double)]
 282 mkChildrenGroups lId addOrRem patches =
 283   [ (lId, parent, child, Just 1)
 284   | (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
 285   , child <- patch ^.. patch_children . to addOrRem . folded
 286   ]
 287
 288 -- Apply the given patch to the DB and returns the patch to be applied on the
 289 -- cilent.
 290 -- TODO:
 291 -- In this perliminary version the OT aspect is missing, therefore the version
 292 -- number is always 1 and the returned patch is always empty.
 293 tableNgramsPatch :: (HasNgramError err, HasNodeError err)
 294                  => CorpusId -> Maybe ListId
 295                  -> Versioned NgramsTablePatch
 296                  -> Cmd err (Versioned NgramsTablePatch)
 297 tableNgramsPatch corpusId maybeList (Versioned version patch) = do
 298   when (version /= 1) $ ngramError UnsupportedVersion
 299   listId <- maybe (defaultList corpusId) pure maybeList
 300   void $ updateNodeNgrams $ NodeNgramsUpdate
 301     { _nnu_lists_update = mkListsUpdate listId patch
 302     , _nnu_rem_children = mkChildrenGroups listId _rem patch
 303     , _nnu_add_children = mkChildrenGroups listId _add patch
 304     }
 305   pure $ Versioned 1 emptyNgramsTablePatch
 306
 307 -- | TODO Errors management
 308 --  TODO: polymorphic for Annuaire or Corpus or ...
 309 getTableNgrams :: HasNodeError err
 310                => CorpusId -> Maybe TabType
 311                -> Maybe ListId -> Maybe Limit -> Maybe Offset
 312                -> Cmd err (Versioned NgramsTable)
 313 getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
 314   let lieu = "Garg.API.Ngrams: " :: Text
 315   let ngramsType = case maybeTabType of
 316         Nothing  -> Ngrams.Sources -- panic (lieu <> "Indicate the Table")
 317         Just tab -> case tab of
 318             Sources    -> Ngrams.Sources
 319             Authors    -> Ngrams.Authors
 320             Institutes -> Ngrams.Institutes
 321             Terms      -> Ngrams.NgramsTerms
 322             _          -> panic $ lieu <> "No Ngrams for this tab"
 323
 324   listId <- maybe (defaultList cId) pure maybeListId
 325
 326   let
 327     defaultLimit = 10 -- TODO
 328     limit_  = maybe defaultLimit identity mlimit
 329     offset_ = maybe 0 identity moffset
 330
 331   (ngramsTableDatas, mapToParent, mapToChildren) <-
 332     Ngrams.getNgramsTableDb NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
 333
 334   -- printDebug "ngramsTableDatas" ngramsTableDatas
 335
 336   pure $ Versioned 1 $
 337          NgramsTable $ map (\(Ngrams.NgramsTableData ngs _ lt w) ->
 338                               NgramsElement ngs
 339                                             (maybe (panic $ lieu <> "listType") identity lt)
 340                                             (round w)
 341                                             (lookup ngs mapToParent)
 342                                             (maybe mempty identity $ lookup ngs mapToChildren)
 343                            ) ngramsTableDatas
 344
 345