Commit e9c12cb0 authored by Alfredo Di Napoli's avatar Alfredo Di Napoli

Use bimaps for HasDbid

This allows us to have only one single (static) map which will be
treated by GHC as a CAF.
parent f4246b5a
...@@ -413,6 +413,7 @@ library ...@@ -413,6 +413,7 @@ library
, base >=4.7 && <5 , base >=4.7 && <5
, base16-bytestring ^>= 1.0.2.0 , base16-bytestring ^>= 1.0.2.0
, base64-bytestring ^>= 1.1.0.0 , base64-bytestring ^>= 1.1.0.0
, bimap >= 0.5.0
, blaze-html ^>= 0.9.1.2 , blaze-html ^>= 0.9.1.2
, blaze-markup ^>= 0.8.2.8 , blaze-markup ^>= 0.8.2.8
, blaze-svg ^>= 0.3.6.1 , blaze-svg ^>= 0.3.6.1
......
...@@ -19,11 +19,12 @@ import Gargantext.API.Admin.Auth.Types ...@@ -19,11 +19,12 @@ import Gargantext.API.Admin.Auth.Types
import Gargantext.API.Auth.PolicyCheck import Gargantext.API.Auth.PolicyCheck
import Gargantext.API.GraphQL.PolicyCheck import Gargantext.API.GraphQL.PolicyCheck
import Gargantext.API.GraphQL.Types import Gargantext.API.GraphQL.Types
import Gargantext.Core (fromDBid)
import Gargantext.Core.Types (Tree, NodeTree, NodeType) import Gargantext.Core.Types (Tree, NodeTree, NodeType)
import Gargantext.Core.Types.Main ( Tree(TreeN), _tn_node, _tn_children, NodeTree(NodeTree, _nt_id, _nt_type), _nt_name ) import Gargantext.Core.Types.Main ( Tree(TreeN), _tn_node, _tn_children, NodeTree(NodeTree, _nt_id, _nt_type), _nt_name )
import Gargantext.Database.Admin.Config (fromNodeTypeId) import Gargantext.Database.Admin.Config ()
import Gargantext.Database.Admin.Types.Node qualified as NN
import Gargantext.Database.Admin.Types.Node (allNodeTypes, NodeId (UnsafeMkNodeId)) import Gargantext.Database.Admin.Types.Node (allNodeTypes, NodeId (UnsafeMkNodeId))
import Gargantext.Database.Admin.Types.Node qualified as NN
import Gargantext.Database.Prelude (CmdCommon) import Gargantext.Database.Prelude (CmdCommon)
import Gargantext.Database.Query.Table.Node (getNode) import Gargantext.Database.Query.Table.Node (getNode)
import Gargantext.Database.Query.Tree qualified as T import Gargantext.Database.Query.Tree qualified as T
...@@ -104,11 +105,11 @@ resolveParent Nothing = pure Nothing ...@@ -104,11 +105,11 @@ resolveParent Nothing = pure Nothing
nodeToTreeNode :: NN.Node json -> Maybe TreeNode nodeToTreeNode :: NN.Node json -> Maybe TreeNode
nodeToTreeNode N.Node {..} = if (fromNodeTypeId _node_typename /= NN.NodeFolderShared) && (fromNodeTypeId _node_typename /= NN.NodeTeam) nodeToTreeNode N.Node {..} = if (fromDBid _node_typename /= NN.NodeFolderShared) && (fromDBid _node_typename /= NN.NodeTeam)
then then
Just TreeNode { id = NN.unNodeId _node_id Just TreeNode { id = NN.unNodeId _node_id
, name = _node_name , name = _node_name
, node_type = fromNodeTypeId _node_typename , node_type = fromDBid _node_typename
, parent_id = NN.unNodeId <$> _node_parent_id , parent_id = NN.unNodeId <$> _node_parent_id
} }
else else
...@@ -121,7 +122,7 @@ convertDbTreeToTreeNode :: T.DbTreeNode -> TreeNode ...@@ -121,7 +122,7 @@ convertDbTreeToTreeNode :: T.DbTreeNode -> TreeNode
convertDbTreeToTreeNode T.DbTreeNode { _dt_name, _dt_nodeId, _dt_typeId, _dt_parentId } = TreeNode convertDbTreeToTreeNode T.DbTreeNode { _dt_name, _dt_nodeId, _dt_typeId, _dt_parentId } = TreeNode
{ name = _dt_name { name = _dt_name
, id = NN.unNodeId _dt_nodeId , id = NN.unNodeId _dt_nodeId
, node_type = fromNodeTypeId _dt_typeId , node_type = fromDBid _dt_typeId
, parent_id = NN.unNodeId <$> _dt_parentId , parent_id = NN.unNodeId <$> _dt_parentId
} }
......
...@@ -10,13 +10,15 @@ Portability : POSIX ...@@ -10,13 +10,15 @@ Portability : POSIX
-} -}
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Gargantext.Core module Gargantext.Core
where where
import Data.Aeson import Data.Aeson
import Data.LanguageCodes qualified as ISO639 import Data.LanguageCodes qualified as ISO639
import Data.Map qualified as Map import Data.Bimap qualified as Bimap
import Data.Bimap (Bimap)
import Data.Morpheus.Types (GQLType) import Data.Morpheus.Types (GQLType)
import Data.Swagger import Data.Swagger
import Data.Text (pack) import Data.Text (pack)
...@@ -132,15 +134,15 @@ allLangs = [minBound .. maxBound] ...@@ -132,15 +134,15 @@ allLangs = [minBound .. maxBound]
class HasDBid a where class HasDBid a where
toDBid :: a -> Int toDBid :: a -> Int
fromDBid :: Int -> a lookupDBid :: Int -> Maybe a
-- NOTE: We try to use numeric codes for countries -- NOTE: We try to use numeric codes for countries
-- https://en.wikipedia.org/wiki/List_of_ISO_3166_country_codes -- https://en.wikipedia.org/wiki/List_of_ISO_3166_country_codes
-- https://en.wikipedia.org/wiki/ISO_3166-1_numeric#004 -- https://en.wikipedia.org/wiki/ISO_3166-1_numeric#004
-- The pattern matching ensures this mapping will always be total -- The pattern matching ensures this mapping will always be total
-- once we add a new 'Lang'. -- once we add a new 'Lang'.
lang2id :: Map Lang Int langIds :: Bimap Lang Int
lang2id = Map.fromList $ allLangs <&> \lid -> case lid of langIds = Bimap.fromList $ allLangs <&> \lid -> case lid of
All -> (lid, 0) All -> (lid, 0)
DE -> (lid, 276) DE -> (lid, 276)
EL -> (lid, 300) EL -> (lid, 300)
...@@ -154,19 +156,11 @@ lang2id = Map.fromList $ allLangs <&> \lid -> case lid of ...@@ -154,19 +156,11 @@ lang2id = Map.fromList $ allLangs <&> \lid -> case lid of
UK -> (lid, 804) UK -> (lid, 804)
ZH -> (lid, 156) ZH -> (lid, 156)
-- | /static/ conversion map between an 'Int' and a 'Lang'. Automatically kept up-to-date
-- as it's derived from 'lang2id'.
id2lang :: Map Int Lang
id2lang = Map.fromList . map swap . Map.toList $ lang2id
instance HasDBid Lang where instance HasDBid Lang where
-- /NOTE/ this lookup cannot fail because 'dbIds' is defined as a total function -- /NOTE/ this lookup cannot fail because 'dbIds' is defined as a total function
-- over its domain. -- over its domain.
toDBid lang = lang2id Map.! lang toDBid lang = langIds Bimap.! lang
lookupDBid dbId = Bimap.lookupR dbId langIds
fromDBid dbId = case Map.lookup dbId id2lang of
Just la -> la
Nothing -> panic "HasDBid lang, not implemented"
------------------------------------------------------------------------ ------------------------------------------------------------------------
data NLPServerConfig = NLPServerConfig data NLPServerConfig = NLPServerConfig
...@@ -186,7 +180,13 @@ instance HasDBid PosTagAlgo where ...@@ -186,7 +180,13 @@ instance HasDBid PosTagAlgo where
toDBid CoreNLP = 1 toDBid CoreNLP = 1
toDBid JohnSnowServer = 2 toDBid JohnSnowServer = 2
toDBid Spacy = 3 toDBid Spacy = 3
fromDBid 1 = CoreNLP lookupDBid 1 = Just CoreNLP
fromDBid 2 = JohnSnowServer lookupDBid 2 = Just JohnSnowServer
fromDBid 3 = Spacy lookupDBid 3 = Just Spacy
fromDBid _ = panic "HasDBid posTagAlgo : Not implemented" lookupDBid _ = Nothing
fromDBid :: forall a. (HasCallStack, HasDBid a, Typeable a) => Int -> a
fromDBid i = case lookupDBid i of
Nothing -> panic $ "HasDBid " <> show (typeRep (Proxy :: Proxy a)) <> " not found or not implemented."
Just v -> v
...@@ -115,7 +115,7 @@ import GHC.Conc (TVar, newTVar, readTVar, writeTVar) ...@@ -115,7 +115,7 @@ import GHC.Conc (TVar, newTVar, readTVar, writeTVar)
import Gargantext.API.Ngrams.Types import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types (ListId, NodeId(..), NodeType) import Gargantext.Core.Types (ListId, NodeId(..), NodeType)
import Gargantext.Core.Utils.Prefix (unPrefix) import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Admin.Config (nodeTypeId) import Gargantext.Database.Admin.Config ()
import Gargantext.Database.Prelude (DbCmd', HasConnectionPool(..)) import Gargantext.Database.Prelude (DbCmd', HasConnectionPool(..))
import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams import Gargantext.Database.Query.Table.Ngrams qualified as TableNgrams
import Gargantext.Database.Query.Table.Node.Error (HasNodeError()) import Gargantext.Database.Query.Table.Node.Error (HasNodeError())
...@@ -123,6 +123,7 @@ import Gargantext.Database.Schema.Ngrams (NgramsType) ...@@ -123,6 +123,7 @@ import Gargantext.Database.Schema.Ngrams (NgramsType)
import Gargantext.Prelude hiding (to) import Gargantext.Prelude hiding (to)
import Gargantext.Prelude.Database import Gargantext.Prelude.Database
import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField) import Opaleye (DefaultFromField(..), SqlJsonb, fromPGSFromField)
import Gargantext.Core (toDBid)
------------------------------------------------------------------------ ------------------------------------------------------------------------
data NodeStoryEnv = NodeStoryEnv data NodeStoryEnv = NodeStoryEnv
...@@ -303,7 +304,7 @@ nodeExists c nId = (== [PGS.Only True]) ...@@ -303,7 +304,7 @@ nodeExists c nId = (== [PGS.Only True])
getNodesIdWithType :: PGS.Connection -> NodeType -> IO [NodeId] getNodesIdWithType :: PGS.Connection -> NodeType -> IO [NodeId]
getNodesIdWithType c nt = do getNodesIdWithType c nt = do
ns <- runPGSQuery c query (PGS.Only $ nodeTypeId nt) ns <- runPGSQuery c query (PGS.Only $ toDBid nt)
pure $ map (\(PGS.Only nId) -> UnsafeMkNodeId nId) ns pure $ map (\(PGS.Only nId) -> UnsafeMkNodeId nId) ns
where where
query :: PGS.Query query :: PGS.Query
......
...@@ -14,8 +14,9 @@ module Gargantext.Core.Text.List.Social.Find ...@@ -14,8 +14,9 @@ module Gargantext.Core.Text.List.Social.Find
-- findList imports -- findList imports
import Control.Lens (view) import Control.Lens (view)
import Gargantext.Core (toDBid)
import Gargantext.Core.Types.Individu import Gargantext.Core.Types.Individu
import Gargantext.Database.Admin.Config import Gargantext.Database.Admin.Config ()
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (DBCmd) import Gargantext.Database.Prelude (DBCmd)
import Gargantext.Database.Query.Table.Node.Error import Gargantext.Database.Query.Table.Node.Error
...@@ -28,7 +29,7 @@ findListsId :: (HasNodeError err, HasTreeError err) ...@@ -28,7 +29,7 @@ findListsId :: (HasNodeError err, HasTreeError err)
=> User -> NodeMode -> DBCmd err [NodeId] => User -> NodeMode -> DBCmd err [NodeId]
findListsId u mode = do findListsId u mode = do
rootId <- getRootId u rootId <- getRootId u
ns <- map (view dt_nodeId) <$> filter ((== nodeTypeId NodeList) . (view dt_typeId)) ns <- map (view dt_nodeId) <$> filter ((== toDBid NodeList) . (view dt_typeId))
<$> findNodes' rootId mode <$> findNodes' rootId mode
pure ns pure ns
......
...@@ -19,7 +19,7 @@ module Gargantext.Core.Types.Main where ...@@ -19,7 +19,7 @@ module Gargantext.Core.Types.Main where
import Data.Aeson (FromJSON, ToJSON) import Data.Aeson (FromJSON, ToJSON)
import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
import Data.Map.Strict (fromList, lookup) import Data.Bimap (Bimap)
import Data.Swagger import Data.Swagger
import Data.Text (unpack, pack) import Data.Text (unpack, pack)
import Gargantext.Core import Gargantext.Core
...@@ -29,6 +29,7 @@ import Gargantext.Prelude ...@@ -29,6 +29,7 @@ import Gargantext.Prelude
import Servant.API (FromHttpApiData(..), ToHttpApiData(..)) import Servant.API (FromHttpApiData(..), ToHttpApiData(..))
import Test.QuickCheck (elements) import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary) import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
import qualified Data.Bimap as Bimap
type CorpusName = Text type CorpusName = Text
------------------------------------------------------------------------ ------------------------------------------------------------------------
...@@ -79,21 +80,20 @@ instance ToHttpApiData ListType where ...@@ -79,21 +80,20 @@ instance ToHttpApiData ListType where
type ListTypeId = Int type ListTypeId = Int
instance HasDBid ListType where instance HasDBid ListType where
toDBid = listTypeId toDBid lt = listTypeIds Bimap.! lt -- cannot fail, see /NOTE/ below.
fromDBid = (fromMaybe (panic "Instance HasDBid fromDBid ListType")) . fromListTypeId lookupDBid = fromListTypeId
-- FIXME Candidate: 0 and Stop : 1 -- FIXME Candidate: 0 and Stop : 1
listTypeId :: ListType -> ListTypeId -- | Bidirectional map between a 'ListType' and a 'ListTypeId'.
listTypeId StopTerm = 0 -- /NOTE/: The way this is constructed is total in its domain.
listTypeId CandidateTerm = 1 listTypeIds :: Bimap ListType ListTypeId
listTypeId MapTerm = 2 listTypeIds = Bimap.fromList $ [minBound .. maxBound] <&> \lt -> case lt of
StopTerm -> (lt, 0)
CandidateTerm -> (lt, 1)
MapTerm -> (lt, 2)
fromListTypeId :: ListTypeId -> Maybe ListType fromListTypeId :: ListTypeId -> Maybe ListType
fromListTypeId i = lookup i fromListTypeId = flip Bimap.lookupR listTypeIds
$ fromList
[ (listTypeId l, l)
| l <- [StopTerm, CandidateTerm, MapTerm]
]
-- data Metrics = Occurrences | Cooccurrences | Specclusion | Genclusion | Cvalue -- data Metrics = Occurrences | Cooccurrences | Specclusion | Genclusion | Cvalue
-- | TfidfCorpus | TfidfGlobal | TirankLocal | TirankGlobal -- | TfidfCorpus | TfidfGlobal | TirankLocal | TirankGlobal
......
...@@ -24,6 +24,7 @@ import Gargantext.Database.Query.Table.ContextNodeNgrams ...@@ -24,6 +24,7 @@ import Gargantext.Database.Query.Table.ContextNodeNgrams
import Gargantext.Database.Schema.Ngrams import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Types import Gargantext.Database.Types
import Gargantext.Prelude import Gargantext.Prelude
import Gargantext.Core (toDBid)
data DocumentIdWithNgrams a b = data DocumentIdWithNgrams a b =
...@@ -41,7 +42,7 @@ insertDocNgrams lId m = do ...@@ -41,7 +42,7 @@ insertDocNgrams lId m = do
where where
ns = [ ContextNodeNgrams (nodeId2ContextId docId) ns = [ ContextNodeNgrams (nodeId2ContextId docId)
lId (ng^.index) lId (ng^.index)
(ngramsTypeId t) (NgramsTypeId $ toDBid t)
(fromIntegral i) (fromIntegral i)
cnt cnt
| (ng, t2n2i) <- HashMap.toList m | (ng, t2n2i) <- HashMap.toList m
......
...@@ -31,7 +31,7 @@ import Gargantext.Core ...@@ -31,7 +31,7 @@ import Gargantext.Core
import Gargantext.Data.HashMap.Strict.Utils as HM import Gargantext.Data.HashMap.Strict.Utils as HM
import Gargantext.Database.Admin.Types.Node (ListId, CorpusId, NodeId(..), ContextId (..), MasterCorpusId, NodeType(NodeDocument), UserCorpusId, DocId) import Gargantext.Database.Admin.Types.Node (ListId, CorpusId, NodeId(..), ContextId (..), MasterCorpusId, NodeType(NodeDocument), UserCorpusId, DocId)
import Gargantext.Database.Prelude (DBCmd, runPGSQuery) import Gargantext.Database.Prelude (DBCmd, runPGSQuery)
import Gargantext.Database.Schema.Ngrams (ngramsTypeId, NgramsType(..)) import Gargantext.Database.Schema.Ngrams (NgramsType(..))
import Gargantext.Prelude import Gargantext.Prelude
-- | fst is size of Supra Corpus -- | fst is size of Supra Corpus
...@@ -72,7 +72,7 @@ getContextsByNgramsUser cId nt = ...@@ -72,7 +72,7 @@ getContextsByNgramsUser cId nt =
runPGSQuery queryNgramsByContextUser runPGSQuery queryNgramsByContextUser
( cId' ( cId'
, toDBid NodeDocument , toDBid NodeDocument
, ngramsTypeId nt' , toDBid nt'
-- , 100 :: Int -- limit -- , 100 :: Int -- limit
-- , 0 :: Int -- offset -- , 0 :: Int -- offset
) )
...@@ -118,7 +118,7 @@ getOccByNgramsOnlyFast cId lId nt = do ...@@ -118,7 +118,7 @@ getOccByNgramsOnlyFast cId lId nt = do
run cId' lId' nt' = runPGSQuery query run cId' lId' nt' = runPGSQuery query
( cId' ( cId'
, lId' , lId'
, ngramsTypeId nt' , toDBid nt'
) )
query :: DPS.Query query :: DPS.Query
...@@ -186,7 +186,7 @@ selectNgramsOccurrencesOnlyByContextUser_withSample cId int nt tms = ...@@ -186,7 +186,7 @@ selectNgramsOccurrencesOnlyByContextUser_withSample cId int nt tms =
, cId , cId
, Values fields ((DPS.Only . unNgramsTerm) <$> (List.take 10000 tms)) , Values fields ((DPS.Only . unNgramsTerm) <$> (List.take 10000 tms))
, cId , cId
, ngramsTypeId nt , toDBid nt
) )
where where
fields = [QualifiedIdentifier Nothing "text"] fields = [QualifiedIdentifier Nothing "text"]
...@@ -221,7 +221,7 @@ selectNgramsOccurrencesOnlyByContextUser_withSample' cId int nt = ...@@ -221,7 +221,7 @@ selectNgramsOccurrencesOnlyByContextUser_withSample' cId int nt =
, toDBid NodeDocument , toDBid NodeDocument
, cId , cId
, cId , cId
, ngramsTypeId nt , toDBid nt
) )
queryNgramsOccurrencesOnlyByContextUser_withSample' :: DPS.Query queryNgramsOccurrencesOnlyByContextUser_withSample' :: DPS.Query
...@@ -285,7 +285,7 @@ selectNgramsOnlyByContextUser cId ls nt tms = ...@@ -285,7 +285,7 @@ selectNgramsOnlyByContextUser cId ls nt tms =
(DPS.Only <$> map DPS.toField ls) (DPS.Only <$> map DPS.toField ls)
, cId , cId
, toDBid NodeDocument , toDBid NodeDocument
, ngramsTypeId nt , toDBid nt
) )
where where
fields = [QualifiedIdentifier Nothing "text"] fields = [QualifiedIdentifier Nothing "text"]
...@@ -330,7 +330,7 @@ selectNgramsOnlyByDocUser dId ls nt tms = ...@@ -330,7 +330,7 @@ selectNgramsOnlyByDocUser dId ls nt tms =
, Values [QualifiedIdentifier Nothing "int4"] , Values [QualifiedIdentifier Nothing "int4"]
(DPS.Only <$> (map DPS.toField ls)) (DPS.Only <$> (map DPS.toField ls))
, dId , dId
, ngramsTypeId nt , toDBid nt
) )
where where
fields = [QualifiedIdentifier Nothing "text"] fields = [QualifiedIdentifier Nothing "text"]
...@@ -370,7 +370,7 @@ selectNgramsByContextMaster :: HasDBid NodeType ...@@ -370,7 +370,7 @@ selectNgramsByContextMaster :: HasDBid NodeType
selectNgramsByContextMaster n ucId mcId p = runPGSQuery selectNgramsByContextMaster n ucId mcId p = runPGSQuery
queryNgramsByContextMaster' queryNgramsByContextMaster'
( ucId ( ucId
, ngramsTypeId NgramsTerms , toDBid NgramsTerms
, toDBid NodeDocument , toDBid NodeDocument
, p , p
, toDBid NodeDocument , toDBid NodeDocument
...@@ -378,7 +378,7 @@ selectNgramsByContextMaster n ucId mcId p = runPGSQuery ...@@ -378,7 +378,7 @@ selectNgramsByContextMaster n ucId mcId p = runPGSQuery
, n , n
, mcId , mcId
, toDBid NodeDocument , toDBid NodeDocument
, ngramsTypeId NgramsTerms , toDBid NgramsTerms
) )
-- | TODO fix context_node_ngrams relation -- | TODO fix context_node_ngrams relation
......
...@@ -20,9 +20,9 @@ module Gargantext.Database.Admin.Config ...@@ -20,9 +20,9 @@ module Gargantext.Database.Admin.Config
where where
import Control.Lens (view) import Control.Lens (view)
import Data.List (lookup)
import Data.Text (pack)
import Gargantext.Core (HasDBid(..)) import Gargantext.Core (HasDBid(..))
import Data.Bimap qualified as Bimap
import Data.Bimap (Bimap)
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Schema.Node import Gargantext.Database.Schema.Node
import Gargantext.Prelude import Gargantext.Prelude
...@@ -38,62 +38,10 @@ userArbitrary :: Text ...@@ -38,62 +38,10 @@ userArbitrary :: Text
userArbitrary = "user1" userArbitrary = "user1"
instance HasDBid NodeType where instance HasDBid NodeType where
toDBid = nodeTypeId toDBid n = nodeTypes Bimap.! n -- nodeTypes is total, this cannot fail by construction
fromDBid = fromNodeTypeId lookupDBid i = Bimap.lookupR i nodeTypes
nodeTypeId :: NodeType -> NodeTypeId
nodeTypeId n =
case n of
NodeUser -> 1
NodeFolder -> 2
NodeFolderPrivate -> 20
NodeFolderShared -> 21
NodeTeam -> 210
NodeFolderPublic -> 22
NodeCorpusV3 -> 3
NodeCorpus -> 30
NodeAnnuaire -> 31
NodeTexts -> 40
NodeDocument -> 4
NodeContact -> 41
--NodeSwap -> 19
---- Lists
NodeList -> 5
NodeListCooc -> 50
NodeModel -> 52
---- Scores
-- NodeOccurrences -> 10
NodeGraph -> 9
NodePhylo -> 90
-- NodeChart -> 7
NodeDashboard -> 71
-- NodeNoteBook -> 88
NodeFile -> 101
Notes -> 991
Calc -> 992
NodeFrameNotebook -> 993
NodeFrameVisio -> 994
-- Cooccurrences -> 9
--
-- Specclusion -> 11
-- Genclusion -> 18
-- Cvalue -> 12
--
-- TfidfCorpus -> 13
-- TfidfGlobal -> 14
--
-- TirankLocal -> 16
-- TirankGlobal -> 17
-- Node management
-- NodeFavorites -> 15
hasNodeType :: forall a. Node a -> NodeType -> Bool hasNodeType :: forall a. Node a -> NodeType -> Bool
hasNodeType n nt = (view node_typename n) == (toDBid nt) hasNodeType n nt = (view node_typename n) == (toDBid nt)
...@@ -102,12 +50,28 @@ isInNodeTypes n ts = elem (view node_typename n) (map toDBid ts) ...@@ -102,12 +50,28 @@ isInNodeTypes n ts = elem (view node_typename n) (map toDBid ts)
-- | Nodes are typed in the database according to a specific ID -- | Nodes are typed in the database according to a specific ID
-- --
nodeTypeInv :: [(NodeTypeId, NodeType)] nodeTypes :: Bimap NodeType NodeTypeId
nodeTypeInv = map swap nodeTypes nodeTypes = Bimap.fromList $ allNodeTypes <&> \n -> case n of
NodeUser -> (n, 1)
nodeTypes :: [(NodeType, NodeTypeId)] NodeFolder -> (n, 2)
nodeTypes = [ (n, toDBid n) | n <- allNodeTypes ] NodeFolderPrivate -> (n, 20)
NodeFolderShared -> (n, 21)
fromNodeTypeId :: NodeTypeId -> NodeType NodeTeam -> (n, 210)
fromNodeTypeId tId = fromMaybe (panic $ pack $ "Type Id " <> show tId <> " does not exist") NodeFolderPublic -> (n, 22)
(lookup tId nodeTypeInv) NodeCorpusV3 -> (n, 3)
NodeCorpus -> (n, 30)
NodeAnnuaire -> (n, 31)
NodeTexts -> (n, 40)
NodeDocument -> (n, 4)
NodeContact -> (n, 41)
NodeList -> (n, 5)
NodeListCooc -> (n, 50)
NodeModel -> (n, 52)
NodeGraph -> (n, 9)
NodePhylo -> (n, 90)
NodeDashboard -> (n, 71)
NodeFile -> (n, 101)
Notes -> (n, 991)
Calc -> (n, 992)
NodeFrameNotebook -> (n, 993)
NodeFrameVisio -> (n, 994)
...@@ -16,11 +16,11 @@ Triggers on NodesNodes table. ...@@ -16,11 +16,11 @@ Triggers on NodesNodes table.
module Gargantext.Database.Admin.Trigger.NodesContexts module Gargantext.Database.Admin.Trigger.NodesContexts
where where
-- (ListId, CorpusId, NodeId)
import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Simple.SqlQQ (sql)
import Gargantext.Core import Gargantext.Core
import Gargantext.Database.Admin.Config import Gargantext.Database.Admin.Config ()
import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId) import Gargantext.Database.Admin.Types.Node -- (ListId, CorpusId, NodeId)
-- (ListId, CorpusId, NodeId)
import Gargantext.Database.Prelude (execPGSQuery, DBCmd) import Gargantext.Database.Prelude (execPGSQuery, DBCmd)
import Gargantext.Prelude import Gargantext.Prelude
import qualified Database.PostgreSQL.Simple as DPS import qualified Database.PostgreSQL.Simple as DPS
...@@ -28,7 +28,7 @@ import qualified Database.PostgreSQL.Simple as DPS ...@@ -28,7 +28,7 @@ import qualified Database.PostgreSQL.Simple as DPS
type MasterListId = ListId type MasterListId = ListId
triggerInsertCount :: MasterListId -> DBCmd err Int64 triggerInsertCount :: MasterListId -> DBCmd err Int64
triggerInsertCount lId = execPGSQuery query (lId, nodeTypeId NodeList) triggerInsertCount lId = execPGSQuery query (lId, toDBid NodeList)
where where
query :: DPS.Query query :: DPS.Query
query = [sql| query = [sql|
...@@ -64,7 +64,7 @@ triggerInsertCount lId = execPGSQuery query (lId, nodeTypeId NodeList) ...@@ -64,7 +64,7 @@ triggerInsertCount lId = execPGSQuery query (lId, nodeTypeId NodeList)
triggerUpdateAdd :: MasterListId -> DBCmd err Int64 triggerUpdateAdd :: MasterListId -> DBCmd err Int64
triggerUpdateAdd lId = execPGSQuery query (lId, nodeTypeId NodeList) triggerUpdateAdd lId = execPGSQuery query (lId, toDBid NodeList)
where where
query :: DPS.Query query :: DPS.Query
query = [sql| query = [sql|
...@@ -104,7 +104,7 @@ triggerUpdateAdd lId = execPGSQuery query (lId, nodeTypeId NodeList) ...@@ -104,7 +104,7 @@ triggerUpdateAdd lId = execPGSQuery query (lId, nodeTypeId NodeList)
triggerUpdateDel :: MasterListId -> DBCmd err Int64 triggerUpdateDel :: MasterListId -> DBCmd err Int64
triggerUpdateDel lId = execPGSQuery query (lId, nodeTypeId NodeList) triggerUpdateDel lId = execPGSQuery query (lId, toDBid NodeList)
where where
query :: DPS.Query query :: DPS.Query
query = [sql| query = [sql|
......
...@@ -425,7 +425,7 @@ data NodeType = NodeUser ...@@ -425,7 +425,7 @@ data NodeType = NodeUser
| Notes | Calc | NodeFrameVisio | NodeFrameNotebook | Notes | Calc | NodeFrameVisio | NodeFrameNotebook
| NodeFile | NodeFile
deriving (Show, Read, Eq, Generic, Bounded, Enum) deriving (Show, Read, Eq, Ord, Generic, Bounded, Enum)
instance GQLType NodeType instance GQLType NodeType
...@@ -446,7 +446,7 @@ instance ToField NodeType where ...@@ -446,7 +446,7 @@ instance ToField NodeType where
allNodeTypes :: [NodeType] allNodeTypes :: [NodeType]
allNodeTypes = [minBound ..] allNodeTypes = [minBound .. maxBound]
defaultName :: NodeType -> Text defaultName :: NodeType -> Text
defaultName NodeUser = "User" defaultName NodeUser = "User"
......
...@@ -34,7 +34,7 @@ import Database.PostgreSQL.Simple qualified as PGS (Query, Only(..)) ...@@ -34,7 +34,7 @@ import Database.PostgreSQL.Simple qualified as PGS (Query, Only(..))
import Gargantext.Core import Gargantext.Core
import Gargantext.Core.Types import Gargantext.Core.Types
import Gargantext.Database.Prelude (DBCmd, runPGSQuery) import Gargantext.Database.Prelude (DBCmd, runPGSQuery)
import Gargantext.Database.Schema.Ngrams (NgramsType, ngramsTypeId, fromNgramsTypeId) import Gargantext.Database.Schema.Ngrams (NgramsType, fromNgramsTypeId)
import Gargantext.Database.Schema.NodeNgrams import Gargantext.Database.Schema.NodeNgrams
import Gargantext.Database.Schema.Prelude (Select, FromRow, sql, fromRow, toField, field, Values(..), QualifiedIdentifier(..), selectTable) import Gargantext.Database.Schema.Prelude (Select, FromRow, sql, fromRow, toField, field, Values(..), QualifiedIdentifier(..), selectTable)
import Gargantext.Prelude import Gargantext.Prelude
...@@ -82,7 +82,7 @@ insertNodeNgrams nns = runPGSQuery query (PGS.Only $ Values fields nns') ...@@ -82,7 +82,7 @@ insertNodeNgrams nns = runPGSQuery query (PGS.Only $ Values fields nns')
-> [ toField node_id'' -> [ toField node_id''
, toField $ toDBid node_subtype , toField $ toDBid node_subtype
, toField $ ngrams_terms , toField $ ngrams_terms
, toField $ ngramsTypeId ngrams_type , toField $ toDBid ngrams_type
, toField $ fromMaybe 0 ngrams_field , toField $ fromMaybe 0 ngrams_field
, toField $ fromMaybe 0 ngrams_tag , toField $ fromMaybe 0 ngrams_tag
, toField $ fromMaybe 0 ngrams_class , toField $ fromMaybe 0 ngrams_class
......
...@@ -52,10 +52,11 @@ module Gargantext.Database.Query.Table.User ...@@ -52,10 +52,11 @@ module Gargantext.Database.Query.Table.User
import Control.Arrow (returnA) import Control.Arrow (returnA)
import Control.Lens ((^.), (?~)) import Control.Lens ((^.), (?~))
import Data.List.NonEmpty qualified as NE
import Data.Proxy import Data.Proxy
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Data.UUID qualified as UUID import Data.UUID qualified as UUID
import Gargantext.Core (HasDBid) import Gargantext.Core (HasDBid, toDBid)
import Gargantext.Core.Types.Individu import Gargantext.Core.Types.Individu
import Gargantext.Database.Admin.Config (nodeTypeId) import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..), hu_pubmed_api_key, hu_epo_api_user, hu_epo_api_token) import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..), hu_pubmed_api_key, hu_epo_api_user, hu_epo_api_token)
...@@ -70,7 +71,6 @@ import Gargantext.Prelude ...@@ -70,7 +71,6 @@ import Gargantext.Prelude
import Gargantext.Prelude.Crypto.Auth qualified as Auth import Gargantext.Prelude.Crypto.Auth qualified as Auth
import Opaleye import Opaleye
import PUBMED.Types qualified as PUBMED import PUBMED.Types qualified as PUBMED
import qualified Data.List.NonEmpty as NE
------------------------------------------------------------------------ ------------------------------------------------------------------------
-- TODO: on conflict, nice message -- TODO: on conflict, nice message
...@@ -164,7 +164,7 @@ getUsersWithId (RootId i) = map toUserLight <$> runOpaQuery (selectUsersLightWit ...@@ -164,7 +164,7 @@ getUsersWithId (RootId i) = map toUserLight <$> runOpaQuery (selectUsersLightWit
selectUsersLightWithId i' = proc () -> do selectUsersLightWithId i' = proc () -> do
n <- queryNodeTable -< () n <- queryNodeTable -< ()
restrict -< n^.node_id .== pgNodeId i' restrict -< n^.node_id .== pgNodeId i'
restrict -< n^.node_typename .== sqlInt4 (nodeTypeId NodeUser) restrict -< n^.node_typename .== sqlInt4 (toDBid NodeUser)
row <- queryUserTable -< () row <- queryUserTable -< ()
restrict -< user_id row .== n^.node_user_id restrict -< user_id row .== n^.node_user_id
returnA -< row returnA -< row
...@@ -192,7 +192,7 @@ getUserHyperdata (UserDBId uId) = do ...@@ -192,7 +192,7 @@ getUserHyperdata (UserDBId uId) = do
selectUserHyperdataWithId i' = proc () -> do selectUserHyperdataWithId i' = proc () -> do
row <- queryNodeTable -< () row <- queryNodeTable -< ()
restrict -< row^.node_user_id .== sqlInt4 i' restrict -< row^.node_user_id .== sqlInt4 i'
restrict -< row^.node_typename .== sqlInt4 (nodeTypeId NodeUser) restrict -< row^.node_typename .== sqlInt4 (toDBid NodeUser)
returnA -< row^.node_hyperdata returnA -< row^.node_hyperdata
getUserHyperdata _ = undefined getUserHyperdata _ = undefined
...@@ -214,7 +214,7 @@ getUserNodeHyperdata (UserDBId uId) = do ...@@ -214,7 +214,7 @@ getUserNodeHyperdata (UserDBId uId) = do
selectUserHyperdataWithId i' = proc () -> do selectUserHyperdataWithId i' = proc () -> do
row <- queryNodeTable -< () row <- queryNodeTable -< ()
restrict -< row^.node_user_id .== sqlInt4 i' restrict -< row^.node_user_id .== sqlInt4 i'
restrict -< row^.node_typename .== sqlInt4 (nodeTypeId NodeUser) restrict -< row^.node_typename .== sqlInt4 (toDBid NodeUser)
returnA -< row returnA -< row
getUserNodeHyperdata _ = undefined getUserNodeHyperdata _ = undefined
......
...@@ -53,7 +53,7 @@ import Database.PostgreSQL.Simple ...@@ -53,7 +53,7 @@ import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.SqlQQ import Database.PostgreSQL.Simple.SqlQQ
import Gargantext.Core import Gargantext.Core
import Gargantext.Core.Types.Main (NodeTree(..), Tree(..)) import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
import Gargantext.Database.Admin.Config (fromNodeTypeId, nodeTypeId, fromNodeTypeId) import Gargantext.Database.Admin.Config ()
import Gargantext.Database.Admin.Types.Hyperdata.Any (HyperdataAny) import Gargantext.Database.Admin.Types.Hyperdata.Any (HyperdataAny)
import Gargantext.Database.Admin.Types.Node import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude (runPGSQuery, DBCmd) import Gargantext.Database.Prelude (runPGSQuery, DBCmd)
...@@ -284,7 +284,7 @@ toTree m = ...@@ -284,7 +284,7 @@ toTree m =
toNodeTree :: DbTreeNode toNodeTree :: DbTreeNode
-> NodeTree -> NodeTree
toNodeTree (DbTreeNode nId tId _ n) = NodeTree n (fromNodeTypeId tId) nId toNodeTree (DbTreeNode nId tId _ n) = NodeTree n (fromDBid tId) nId
------------------------------------------------------------------------ ------------------------------------------------------------------------
toTreeParent :: [DbTreeNode] toTreeParent :: [DbTreeNode]
...@@ -353,7 +353,7 @@ dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) ...@@ -353,7 +353,7 @@ dbTree rootId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n)
SELECT * from tree; SELECT * from tree;
|] (rootId, In typename) |] (rootId, In typename)
where where
typename = map nodeTypeId ns typename = map toDBid ns
ns = case nodeTypes of ns = case nodeTypes of
[] -> allNodeTypes [] -> allNodeTypes
_ -> nodeTypes _ -> nodeTypes
...@@ -447,7 +447,7 @@ recursiveParents nodeId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId t ...@@ -447,7 +447,7 @@ recursiveParents nodeId nodeTypes = map (\(nId, tId, pId, n) -> DbTreeNode nId t
) SELECT id, typename, parent_id, name FROM recursiveParents ORDER BY original_order DESC; ) SELECT id, typename, parent_id, name FROM recursiveParents ORDER BY original_order DESC;
|] (nodeId, In typename) |] (nodeId, In typename)
where where
typename = map nodeTypeId ns typename = map toDBid ns
ns = case nodeTypes of ns = case nodeTypes of
[] -> allNodeTypes [] -> allNodeTypes
_ -> nodeTypes _ -> nodeTypes
......
...@@ -24,10 +24,11 @@ import Codec.Serialise (Serialise()) ...@@ -24,10 +24,11 @@ import Codec.Serialise (Serialise())
import Control.Lens (over) import Control.Lens (over)
import Data.Aeson import Data.Aeson
import Data.Aeson.Types (toJSONKeyText) import Data.Aeson.Types (toJSONKeyText)
import Data.Bimap (Bimap)
import Data.Bimap qualified as Bimap
import Data.ByteString.Char8 qualified as B import Data.ByteString.Char8 qualified as B
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap import Data.HashMap.Strict qualified as HashMap
import Data.Map.Strict (fromList, lookup)
import Data.Text (splitOn, pack, strip) import Data.Text (splitOn, pack, strip)
import Database.PostgreSQL.Simple qualified as PGS import Database.PostgreSQL.Simple qualified as PGS
import Database.PostgreSQL.Simple.FromField (returnError, ResultError(..)) import Database.PostgreSQL.Simple.FromField (returnError, ResultError(..))
...@@ -124,7 +125,7 @@ instance FromField NgramsType where ...@@ -124,7 +125,7 @@ instance FromField NgramsType where
else else
returnError ConversionFailed fld dat returnError ConversionFailed fld dat
instance ToField NgramsType where instance ToField NgramsType where
toField nt = toField $ ngramsTypeId nt toField nt = toField $ toDBid nt
ngramsTypes :: [NgramsType] ngramsTypes :: [NgramsType]
...@@ -149,22 +150,22 @@ instance DefaultFromField (Nullable SqlInt4) NgramsTypeId ...@@ -149,22 +150,22 @@ instance DefaultFromField (Nullable SqlInt4) NgramsTypeId
defaultFromField = fromPGSFromField defaultFromField = fromPGSFromField
pgNgramsType :: NgramsType -> Field SqlInt4 pgNgramsType :: NgramsType -> Field SqlInt4
pgNgramsType = pgNgramsTypeId . ngramsTypeId pgNgramsType = pgNgramsTypeId . NgramsTypeId . toDBid
pgNgramsTypeId :: NgramsTypeId -> Field SqlInt4 pgNgramsTypeId :: NgramsTypeId -> Field SqlInt4
pgNgramsTypeId (NgramsTypeId n) = sqlInt4 n pgNgramsTypeId (NgramsTypeId n) = sqlInt4 n
ngramsTypeId :: NgramsType -> NgramsTypeId -- | Bidirectional map between an 'NgramsType' and its id.
ngramsTypeId Authors = 1 -- /NOTE/ This function is total in its domain by construction.
ngramsTypeId Institutes = 2 ngramsTypeIds :: Bimap NgramsType NgramsTypeId
ngramsTypeId Sources = 3 ngramsTypeIds = Bimap.fromList $ [minBound .. maxBound] <&> \nt -> case nt of
ngramsTypeId NgramsTerms = 4 Authors -> (nt, 1)
Institutes -> (nt, 2)
Sources -> (nt, 3)
NgramsTerms -> (nt, 4)
fromNgramsTypeId :: NgramsTypeId -> Maybe NgramsType fromNgramsTypeId :: NgramsTypeId -> Maybe NgramsType
fromNgramsTypeId id = lookup id fromNgramsTypeId nid = Bimap.lookupR nid ngramsTypeIds
$ fromList [ (ngramsTypeId nt,nt)
| nt <- [minBound .. maxBound] :: [NgramsType]
]
unNgramsTypeId :: NgramsTypeId -> Int unNgramsTypeId :: NgramsTypeId -> Int
unNgramsTypeId (NgramsTypeId i) = i unNgramsTypeId (NgramsTypeId i) = i
...@@ -173,8 +174,8 @@ toNgramsTypeId :: Int -> NgramsTypeId ...@@ -173,8 +174,8 @@ toNgramsTypeId :: Int -> NgramsTypeId
toNgramsTypeId i = NgramsTypeId i toNgramsTypeId i = NgramsTypeId i
instance HasDBid NgramsType where instance HasDBid NgramsType where
toDBid = unNgramsTypeId . ngramsTypeId toDBid nt = unNgramsTypeId $ ngramsTypeIds Bimap.! nt -- cannot fail
fromDBid = fromMaybe (panic "NgramsType id not indexed") . fromNgramsTypeId . toNgramsTypeId lookupDBid = fromNgramsTypeId . toNgramsTypeId
------------------------------------------------------------------------ ------------------------------------------------------------------------
------------------------------------------------------------------------ ------------------------------------------------------------------------
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment