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 TemplateHaskell   #-}
  27 {-# LANGUAGE TypeOperators     #-}
  28 {-# LANGUAGE FlexibleInstances #-}
  29
  30 module Gargantext.API.Ngrams
  31   where
  32
  33 -- import Gargantext.Database.User  (UserId)
  34 --import Data.Map.Strict.Patch (Patch, replace, fromList)
  35 --import Data.Maybe (catMaybes)
  36 --import qualified Data.Map.Strict as DM
  37 --import qualified Data.Set as Set
  38 import Control.Lens (view)
  39 import Data.Aeson (FromJSON, ToJSON)
  40 import Data.Aeson.TH (deriveJSON)
  41 import Data.Either(Either(Left))
  42 import Data.List (concat)
  43 import Data.Set (Set)
  44 import Data.Swagger (ToSchema, ToParamSchema)
  45 import Data.Text (Text)
  46 import Database.PostgreSQL.Simple (Connection)
  47 import GHC.Generics (Generic)
  48 import Gargantext.Core.Types (node_id)
  49 import Gargantext.Core.Types.Main (Tree(..))
  50 import Gargantext.Core.Utils.Prefix (unPrefix)
  51 import Gargantext.Database.Ngrams (NgramsId)
  52 import Gargantext.Database.Node (getListsWithParentId)
  53 import Gargantext.Database.NodeNgram -- (NodeNgram(..), NodeNgram, updateNodeNgrams, NodeNgramPoly)
  54 import Gargantext.Database.NodeNgramsNgrams -- (NodeNgramsNgramsPoly(NodeNgramsNgrams))
  55 import Gargantext.Prelude
  56 import Gargantext.Text.List.Types (ListType(..), listTypeId, ListId, ListTypeId)
  57 import Prelude (Enum, Bounded, minBound, maxBound)
  58 import Servant hiding (Patch)
  59 import Test.QuickCheck (elements)
  60 import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
  61 import qualified Data.Set as Set
  62
  63 ------------------------------------------------------------------------
  64 --data FacetFormat = Table | Chart
  65 data TabType   = Docs   | Terms  | Sources | Authors | Trash
  66   deriving (Generic, Enum, Bounded)
  67
  68 instance FromHttpApiData TabType
  69   where
  70     parseUrlPiece "Docs"    = pure Docs
  71     parseUrlPiece "Terms"   = pure Terms
  72     parseUrlPiece "Sources" = pure Sources
  73     parseUrlPiece "Authors" = pure Authors
  74     parseUrlPiece "Trash"   = pure Trash
  75     parseUrlPiece _         = Left "Unexpected value of TabType"
  76
  77 instance ToParamSchema   TabType
  78 instance ToJSON    TabType
  79 instance FromJSON  TabType
  80 instance ToSchema  TabType
  81 instance Arbitrary TabType
  82   where
  83     arbitrary = elements [minBound .. maxBound]
  84
  85 ------------------------------------------------------------------------
  86 data NgramsElement =
  87      NgramsElement { _ne_id     :: Int
  88                    , _ne_ngrams :: Text
  89                    , _ne_list   :: ListType
  90                    }
  91       deriving (Ord, Eq)
  92 $(deriveJSON (unPrefix "_ne_") ''NgramsElement)
  93
  94
  95 data NgramsTable = NgramsTable { _ngramsTable :: [Tree NgramsElement] }
  96   deriving (Ord, Eq, Generic)
  97 $(deriveJSON (unPrefix "_") ''NgramsTable)
  98
  99
 100 ------------------------------------------------------------------------
 101 -- On the Client side:
 102 --data Action = InGroup     NgramsId NgramsId
 103 --            | OutGroup    NgramsId NgramsId
 104 --            | SetListType NgramsId ListType
 105
 106 data NgramsPatch =
 107      NgramsPatch { _np_list_types   :: ListType   -- TODO Map UserId ListType
 108                  , _np_add_children :: Set NgramsId
 109                  , _np_rem_children :: Set NgramsId
 110                  }
 111       deriving (Ord, Eq, Show, Generic)
 112 $(deriveJSON (unPrefix "_np_") ''NgramsPatch)
 113
 114 instance ToSchema  NgramsPatch
 115
 116 instance Arbitrary NgramsPatch where
 117   arbitrary = NgramsPatch <$> arbitrary <*> arbitrary <*> arbitrary
 118
 119                        --
 120
 121 data NgramsIdPatch =
 122      NgramsIdPatch { _nip_ngramsId    :: NgramsId
 123                    , _nip_ngramsPatch :: NgramsPatch
 124                    }
 125       deriving (Ord, Eq, Show, Generic)
 126
 127 $(deriveJSON (unPrefix "_nip_") ''NgramsIdPatch)
 128
 129 instance ToSchema  NgramsIdPatch
 130
 131 instance Arbitrary NgramsIdPatch where
 132   arbitrary = NgramsIdPatch <$> arbitrary <*> arbitrary
 133
 134                        --
 135
 136 data NgramsIdPatchs =
 137      NgramsIdPatchs { _nip_ngramsIdPatchs :: [NgramsIdPatch] }
 138       deriving (Ord, Eq, Show, Generic)
 139 $(deriveJSON (unPrefix "_nip_") ''NgramsIdPatchs)
 140 instance ToSchema  NgramsIdPatchs
 141 instance Arbitrary NgramsIdPatchs where
 142   arbitrary = NgramsIdPatchs <$> arbitrary
 143
 144 ------------------------------------------------------------------------
 145 ------------------------------------------------------------------------
 146 type Version = Int
 147
 148 data Versioned a = Versioned
 149   { _v_version :: Version
 150   , _v_data    :: a
 151   }
 152
 153
 154 {-
 155 -- TODO sequencs of modifications (Patchs)
 156 type NgramsIdPatch = Patch NgramsId NgramsPatch
 157
 158 ngramsPatch :: Int -> NgramsPatch
 159 ngramsPatch n = NgramsPatch (DM.fromList [(1, StopList)]) (Set.fromList [n]) Set.empty
 160
 161 toEdit :: NgramsId -> NgramsPatch -> Edit NgramsId NgramsPatch
 162 toEdit n p = Edit n p
 163 ngramsIdPatch :: Patch NgramsId NgramsPatch
 164 ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ ngramsPatch 1) Nothing
 165                                        , replace (1::NgramsId) Nothing (Just $ ngramsPatch 2)
 166                                        , replace (2::NgramsId) Nothing (Just $ ngramsPatch 2)
 167                                        ]
 168
 169 -- applyPatchBack :: Patch -> IO Patch
 170 -- isEmptyPatch = Map.all (\x -> Set.isEmpty (add_children x) && Set.isEmpty ... )
 171 -}
 172 ------------------------------------------------------------------------
 173 ------------------------------------------------------------------------
 174 ------------------------------------------------------------------------
 175 type CorpusId = Int
 176 type TableNgramsApi = Summary " Table Ngrams API Change"
 177                       :> QueryParam "list"   ListId
 178                       :> ReqBody '[JSON] NgramsIdPatchs
 179                       :> Put     '[JSON] NgramsIdPatchsBack
 180
 181 type TableNgramsApiGet = Summary " Table Ngrams API Get"
 182                       :> QueryParam "ngramsType"   TabType
 183                       :> QueryParam "list"   ListId
 184                       :> Get    '[JSON] NgramsIdPatchsBack
 185
 186 type NgramsIdPatchsFeed = NgramsIdPatchs
 187 type NgramsIdPatchsBack = NgramsIdPatchs
 188
 189
 190 defaultList :: Connection -> CorpusId -> IO ListId
 191 defaultList c cId = view node_id <$> maybe (panic errorMessage) identity
 192   <$> head
 193   <$> getListsWithParentId c cId
 194   where
 195     errorMessage = "Gargantext.API.Ngrams.defaultList: no list found"
 196
 197 toLists :: ListId -> NgramsIdPatchs -> [(ListId, NgramsId, ListTypeId)]
 198 toLists lId np = map (toList lId) (_nip_ngramsIdPatchs np)
 199
 200 toList :: ListId -> NgramsIdPatch -> (ListId, NgramsId, ListTypeId)
 201 toList lId (NgramsIdPatch ngId (NgramsPatch lt _ _)) = (lId,ngId,listTypeId lt)
 202
 203
 204 toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatchs -> [NodeNgramsNgrams]
 205 toGroups lId addOrRem ps = concat $ map (toGroup lId addOrRem) $ _nip_ngramsIdPatchs ps
 206
 207 toGroup :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatch -> [NodeNgramsNgrams]
 208 toGroup lId addOrRem (NgramsIdPatch ngId patch)  =
 209   map (\ng -> (NodeNgramsNgrams lId ngId ng (Just 1))) (Set.toList $ addOrRem patch)
 210
 211
 212 tableNgramsPatch :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> IO NgramsIdPatchsBack
 213 tableNgramsPatch conn corpusId maybeList patchs = do
 214   listId <- case maybeList of
 215               Nothing      -> defaultList conn corpusId
 216               Just listId' -> pure listId'
 217   _ <- ngramsGroup' conn Add $ toGroups listId _np_add_children patchs
 218   _ <- ngramsGroup' conn Del $ toGroups listId _np_rem_children patchs
 219   _ <- updateNodeNgrams conn (toLists listId patchs)
 220   pure (NgramsIdPatchs [])
 221
 222 getTableNgramsPatch :: Connection -> CorpusId -> Maybe TabType -> Maybe ListId -> IO NgramsTable
 223 getTableNgramsPatch = undefined