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 data of NgramsTable
  14 -- post :: update NodeNodeNgrams
  15 -- group ngrams
  16
  17 get ngrams filtered by NgramsType
  18 add get
  19
  20 -}
  21
  22 {-# LANGUAGE DataKinds         #-}
  23 {-# LANGUAGE DeriveGeneric     #-}
  24 {-# LANGUAGE NoImplicitPrelude #-}
  25 {-# LANGUAGE OverloadedStrings #-}
  26 {-# LANGUAGE ScopedTypeVariables #-}
  27 {-# LANGUAGE TemplateHaskell   #-}
  28 {-# LANGUAGE TypeOperators     #-}
  29 {-# LANGUAGE FlexibleInstances #-}
  30 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  31 {-# OPTIONS -fno-warn-orphans #-}
  32
  33 module Gargantext.API.Ngrams
  34   where
  35
  36 import Prelude (round)
  37 -- import Gargantext.Database.Schema.User  (UserId)
  38 import Data.Patch.Class (Replace, replace)
  39 --import qualified Data.Map.Strict.Patch as PM
  40 import Data.Monoid
  41 --import Data.Semigroup
  42 import Data.Set (Set)
  43 import qualified Data.Set as Set
  44 --import Data.Maybe (catMaybes)
  45 --import qualified Data.Map.Strict as DM
  46 --import qualified Data.Set as Set
  47 import Control.Lens ((.~))
  48 import Control.Monad.IO.Class (MonadIO, liftIO)
  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
  55 import Data.Text (Text)
  56 import Database.PostgreSQL.Simple (Connection)
  57 import GHC.Generics (Generic)
  58 --import Gargantext.Core.Types.Main (Tree(..))
  59 import Gargantext.Core.Utils.Prefix (unPrefix)
  60 import Gargantext.Database.Types.Node (NodeType(..))
  61 import Gargantext.Database.Schema.Node (defaultList)
  62 import qualified Gargantext.Database.Schema.Ngrams as Ngrams
  63 import Gargantext.Prelude
  64 import Gargantext.Core.Types (ListType(..), ListId, CorpusId, Limit, Offset)
  65 import Prelude (Enum, Bounded, minBound, maxBound)
  66 import Servant hiding (Patch)
  67 import Test.QuickCheck (elements)
  68 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  69
  70 ------------------------------------------------------------------------
  71 --data FacetFormat = Table | Chart
  72 data TabType   = Docs     | Terms  | Sources | Authors | Institutes | Trash
  73                | Contacts
  74   deriving (Generic, Enum, Bounded)
  75
  76 instance FromHttpApiData TabType
  77   where
  78     parseUrlPiece "Docs"       = pure Docs
  79     parseUrlPiece "Terms"      = pure Terms
  80     parseUrlPiece "Sources"    = pure Sources
  81     parseUrlPiece "Institutes" = pure Institutes
  82     parseUrlPiece "Authors"    = pure Authors
  83     parseUrlPiece "Trash"      = pure Trash
  84
  85     parseUrlPiece "Contacts"   = pure Contacts
  86
  87     parseUrlPiece _            = Left "Unexpected value of TabType"
  88
  89 instance ToParamSchema   TabType
  90 instance ToJSON    TabType
  91 instance FromJSON  TabType
  92 instance ToSchema  TabType
  93 instance Arbitrary TabType
  94   where
  95     arbitrary = elements [minBound .. maxBound]
  96
  97 ------------------------------------------------------------------------
  98 type NgramsTerm = Text
  99
 100 data NgramsElement =
 101      NgramsElement { _ne_ngrams      :: NgramsTerm
 102                    , _ne_list        :: ListType
 103                    , _ne_occurrences :: Int
 104                    , _ne_parent      :: Maybe NgramsTerm
 105                    , _ne_children    :: Set NgramsTerm
 106                    }
 107       deriving (Ord, Eq, Show, Generic)
 108 $(deriveJSON (unPrefix "_ne_") ''NgramsElement)
 109
 110 instance ToSchema NgramsElement
 111 instance Arbitrary NgramsElement where
 112   arbitrary = elements [NgramsElement "sport" GraphList 1 Nothing mempty]
 113
 114 ------------------------------------------------------------------------
 115 newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
 116   deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
 117
 118 instance Arbitrary NgramsTable where
 119   arbitrary = elements
 120               [ NgramsTable
 121                 [ NgramsElement "animal"  GraphList     1  Nothing       (Set.fromList ["dog", "cat"])
 122                 , NgramsElement "cat"     GraphList     1 (Just "animal") mempty
 123                 , NgramsElement "cats"    StopList      4  Nothing        mempty
 124                 , NgramsElement "dog"     GraphList     3 (Just "animal")(Set.fromList ["dogs"])
 125                 , NgramsElement "dogs"    StopList      4 (Just "dog")    mempty
 126                 , NgramsElement "fox"     GraphList     1  Nothing        mempty
 127                 , NgramsElement "object"  CandidateList 2  Nothing        mempty
 128                 , NgramsElement "nothing" StopList      4  Nothing        mempty
 129                 , NgramsElement "organic" GraphList     3  Nothing        (Set.singleton "flower")
 130                 , NgramsElement "flower"  GraphList     3 (Just "organic") mempty
 131                 , NgramsElement "moon"    CandidateList 1  Nothing         mempty
 132                 , NgramsElement "sky"     StopList      1  Nothing         mempty
 133                 ]
 134               ]
 135 instance ToSchema NgramsTable
 136
 137 ------------------------------------------------------------------------
 138 -- On the Client side:
 139 --data Action = InGroup     NgramsId NgramsId
 140 --            | OutGroup    NgramsId NgramsId
 141 --            | SetListType NgramsId ListType
 142
 143 data PatchSet a = PatchSet
 144   { _rem :: Set a
 145   , _add :: Set a
 146   }
 147   deriving (Eq, Ord, Show, Generic)
 148
 149 instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
 150   arbitrary = PatchSet <$> arbitrary <*> arbitrary
 151
 152 instance ToJSON a => ToJSON (PatchSet a) where
 153   toJSON     = genericToJSON     $ unPrefix "_"
 154   toEncoding = genericToEncoding $ unPrefix "_"
 155
 156 instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
 157   parseJSON = genericParseJSON $ unPrefix "_"
 158
 159 instance ToSchema a => ToSchema (PatchSet a)
 160
 161 instance ToSchema a => ToSchema (Replace a) where
 162   declareNamedSchema (_ :: proxy (Replace a)) = do
 163     aSchema <- declareSchemaRef (Proxy :: Proxy a)
 164     return $ NamedSchema (Just "Replace") $ mempty
 165       & type_ .~ SwaggerObject
 166       & properties .~
 167           InsOrdHashMap.fromList
 168           [ ("old", aSchema)
 169           , ("new", aSchema)
 170           ]
 171       & required .~ [ "old", "new" ]
 172
 173 data NgramsPatch =
 174      NgramsPatch { _patch_children :: PatchSet NgramsElement
 175                  , _patch_list     :: Replace ListType   -- TODO Map UserId ListType
 176                  }
 177       deriving (Ord, Eq, Show, Generic)
 178 $(deriveJSON (unPrefix "_") ''NgramsPatch)
 179
 180 -- instance Semigroup NgramsPatch where
 181
 182 instance ToSchema  NgramsPatch
 183
 184 instance Arbitrary NgramsPatch where
 185   arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
 186
 187 data NgramsIdPatch =
 188      NgramsIdPatch { _nip_ngrams      :: NgramsTerm
 189                    , _nip_ngramsPatch :: NgramsPatch
 190                    }
 191       deriving (Ord, Eq, Show, Generic)
 192 $(deriveJSON (unPrefix "_nip_") ''NgramsIdPatch)
 193
 194 instance ToSchema  NgramsIdPatch
 195
 196 instance Arbitrary NgramsIdPatch where
 197   arbitrary = NgramsIdPatch <$> arbitrary <*> arbitrary
 198
 199                        --
 200 -- TODO:
 201 -- * This should be a Map NgramsId NgramsPatch
 202 -- * Patchs -> Patches
 203 newtype NgramsIdPatchs =
 204      NgramsIdPatchs { _nip_ngramsIdPatchs :: [NgramsIdPatch] }
 205       deriving (Ord, Eq, Show, Generic, Arbitrary)
 206 $(deriveJSON (unPrefix "_nip_") ''NgramsIdPatchs)
 207 instance ToSchema  NgramsIdPatchs
 208
 209 ------------------------------------------------------------------------
 210 ------------------------------------------------------------------------
 211 type Version = Int
 212
 213 data Versioned a = Versioned
 214   { _v_version :: Version
 215   , _v_data    :: a
 216   }
 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] NgramsTable
 246
 247 type TableNgramsApi = Summary " Table Ngrams API Change"
 248                       :> QueryParam "list"   ListId
 249                       :> ReqBody '[JSON] NgramsIdPatchsFeed -- Versioned ...
 250                       :> Put     '[JSON] NgramsIdPatchsBack -- Versioned ...
 251
 252 type NgramsIdPatchsFeed = NgramsIdPatchs
 253 type NgramsIdPatchsBack = NgramsIdPatchs
 254
 255
 256 {-
 257 toLists :: ListId -> NgramsIdPatchs -> [(ListId, NgramsId, ListTypeId)]
 258 -- toLists = undefined
 259 toLists lId np = [ (lId,ngId,listTypeId lt) | map (toList lId) (_nip_ngramsIdPatchs np) ]
 260
 261 toList :: ListId -> NgramsIdPatch -> (ListId, NgramsId, ListTypeId)
 262 toList = undefined
 263
 264 toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatchs -> [NodeNgramsNgrams]
 265 toGroups lId addOrRem ps = concat $ map (toGroup lId addOrRem) $ _nip_ngramsIdPatchs ps
 266
 267 toGroup :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatch -> [NodeNgramsNgrams]
 268 -- toGroup = undefined
 269 toGroup lId addOrRem (NgramsIdPatch ngId patch)  =
 270   map (\ng -> (NodeNgramsNgrams lId ngId ng (Just 1))) (Set.toList $ addOrRem patch)
 271
 272 -}
 273
 274 tableNgramsPatch :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> IO NgramsIdPatchsBack
 275 tableNgramsPatch = undefined
 276 {-
 277 tableNgramsPatch conn corpusId maybeList patchs = do
 278   listId <- case maybeList of
 279               Nothing      -> defaultList conn corpusId
 280               Just listId' -> pure listId'
 281   _ <- ngramsGroup' conn Add $ toGroups listId _np_add_children patchs
 282   _ <- ngramsGroup' conn Del $ toGroups listId _np_rem_children patchs
 283   _ <- updateNodeNgrams conn (toLists listId patchs)
 284   pure (NgramsIdPatchs [])
 285 -}
 286
 287 -- | TODO Errors management
 288 --  TODO: polymorphic for Annuaire or Corpus or ...
 289 getTableNgrams :: MonadIO m
 290                => Connection -> CorpusId -> Maybe TabType
 291                -> Maybe ListId -> Maybe Limit -> Maybe Offset
 292                -> m NgramsTable
 293 getTableNgrams c cId maybeTabType maybeListId mlimit moffset = liftIO $ do
 294   let lieu = "Garg.API.Ngrams: " :: Text
 295   let ngramsType = case maybeTabType of
 296         Nothing  -> Ngrams.Sources -- panic (lieu <> "Indicate the Table")
 297         Just tab -> case tab of
 298             Sources    -> Ngrams.Sources
 299             Authors    -> Ngrams.Authors
 300             Institutes -> Ngrams.Institutes
 301             Terms      -> Ngrams.NgramsTerms
 302             _          -> panic $ lieu <> "No Ngrams for this tab"
 303
 304   listId <- case maybeListId of
 305       Nothing -> defaultList c cId
 306       Just lId -> pure lId
 307
 308   let
 309     defaultLimit = 10 -- TODO
 310     limit_  = maybe defaultLimit identity mlimit
 311     offset_ = maybe 0 identity moffset
 312
 313   (ngramsTableDatas, mapToParent, mapToChildren) <-
 314     Ngrams.getNgramsTableDb c NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
 315
 316   -- printDebug "ngramsTableDatas" ngramsTableDatas
 317
 318   pure $ NgramsTable $ map (\(Ngrams.NgramsTableData ngs _ lt w) ->
 319                               NgramsElement ngs
 320                                             (maybe (panic $ lieu <> "listType") identity lt)
 321                                             (round w)
 322                                             (lookup ngs mapToParent)
 323                                             (maybe mempty identity $ lookup ngs mapToChildren)
 324                            ) ngramsTableDatas
 325
 326