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