Skip to content

haskell-gargantext
haskell-gargantext
Commit 70057b4c authored by Alexandre Delanoë's avatar Alexandre Delanoë
Browse files
Options

[FIX] Instances declations: HasDBid NodeType (more ids for types coming)

parent b5c9a011
Hide whitespace changes
Inline Side-by-side
Showing with 78 additions and 56 deletions
src/Gargantext/Database/Action/Delete.hs
View file @ 70057b4c
......@@ -25,7 +25,6 @@ import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Action.User (getUserId)
import Gargantext.Database.Action.Share (delFolderTeam)
import Gargantext.Core
import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Hyperdata.File
import Gargantext.Database.Admin.Types.Node -- (NodeType(..))
import Gargantext.Database.Prelude (Cmd', HasConfig, HasConnectionPool)
......
src/Gargantext/Database/Action/Learn.hs
View file @ 70057b4c
......@@ -17,6 +17,7 @@ module Gargantext.Database.Action.Learn
import Data.Maybe
import Data.Text (Text)
import Gargantext.Core
import Gargantext.Core.Types (Offset, Limit)
import Gargantext.Database.Query.Facet
import Gargantext.Database.Admin.Types.Hyperdata
......@@ -31,14 +32,15 @@ data FavOrTrash = IsFav | IsTrash
deriving (Eq)
moreLike :: CorpusId -> Maybe Offset -> Maybe Limit -> Maybe OrderBy
moreLike :: HasDBid NodeType
=> CorpusId -> Maybe Offset -> Maybe Limit -> Maybe OrderBy
-> FavOrTrash -> Cmd err [FacetDoc]
moreLike cId o _l order ft = do
priors <- getPriors ft cId
moreLikeWith cId o (Just 3) order ft priors
---------------------------------------------------------------------------
getPriors :: FavOrTrash -> CorpusId -> Cmd err (Events Bool)
getPriors :: HasDBid NodeType => FavOrTrash -> CorpusId -> Cmd err (Events Bool)
getPriors ft cId = do
docs_fav <- filter (\(FacetDoc _ _ _ _ f _ _) -> f == Just 2)
......@@ -54,7 +56,8 @@ getPriors ft cId = do
pure priors
moreLikeWith :: CorpusId -> Maybe Offset -> Maybe Limit -> Maybe OrderBy
moreLikeWith :: HasDBid NodeType
=> CorpusId -> Maybe Offset -> Maybe Limit -> Maybe OrderBy
-> FavOrTrash -> Events Bool -> Cmd err [FacetDoc]
moreLikeWith cId o l order ft priors = do
......
src/Gargantext/Database/Action/Node.hs
View file @ 70057b4c
......@@ -20,6 +20,7 @@ Portability : POSIX
module Gargantext.Database.Action.Node
where
import Gargantext.Core
import Gargantext.Core.Types (Name)
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Hyperdata.Default
......@@ -35,7 +36,7 @@ import Gargantext.Prelude.Config (GargConfig(..))
------------------------------------------------------------------------
-- | TODO mk all others nodes
mkNodeWithParent :: (HasNodeError err)
mkNodeWithParent :: (HasNodeError err, HasDBid NodeType)
=> NodeType
-> Maybe ParentId
-> UserId
......@@ -66,7 +67,7 @@ mkNodeWithParent nt (Just pId) uId name = insertNode nt (Just name) Nothing pId
-- | Sugar to create a node, get its NodeId and update its Hyperdata after
mkNodeWithParent_ConfigureHyperdata :: (HasNodeError err)
mkNodeWithParent_ConfigureHyperdata :: (HasNodeError err, HasDBid NodeType)
=> NodeType
-> Maybe ParentId
-> UserId
......@@ -85,7 +86,7 @@ mkNodeWithParent_ConfigureHyperdata _ _ _ _ = nodeError NotImplYet
-- | Function not exposed
mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err)
mkNodeWithParent_ConfigureHyperdata' :: (HasNodeError err, HasDBid NodeType)
=> NodeType
-> Maybe ParentId
-> UserId
......
src/Gargantext/Database/Action/Search.hs
View file @ 70057b4c
......@@ -24,7 +24,6 @@ import Database.PostgreSQL.Simple (Query)
import Database.PostgreSQL.Simple.ToField
import Gargantext.Core
import Gargantext.Core.Types
import Gargantext.Database.Admin.Config
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..), HyperdataContact(..))
import Gargantext.Database.Prelude (Cmd, runPGSQuery, runOpaQuery, runCountOpaQuery)
import Gargantext.Database.Query.Facet
......@@ -40,9 +39,10 @@ import Data.Profunctor.Product (p4)
import qualified Opaleye as O hiding (Order)
------------------------------------------------------------------------
searchDocInDatabase :: ParentId
-> Text
-> Cmd err [(NodeId, HyperdataDocument)]
searchDocInDatabase :: HasDBid NodeType
=> ParentId
-> Text
-> Cmd err [(NodeId, HyperdataDocument)]
searchDocInDatabase p t = runOpaQuery (queryDocInDatabase p t)
where
-- | Global search query where ParentId is Master Node Corpus Id
......@@ -55,7 +55,8 @@ searchDocInDatabase p t = runOpaQuery (queryDocInDatabase p t)
------------------------------------------------------------------------
-- | todo add limit and offset and order
searchInCorpus :: CorpusId
searchInCorpus :: HasDBid NodeType
=> CorpusId
-> IsTrash
-> [Text]
-> Maybe Offset
......@@ -68,7 +69,8 @@ searchInCorpus cId t q o l order = runOpaQuery
$ intercalate " | "
$ map stemIt q
searchCountInCorpus :: CorpusId
searchCountInCorpus :: HasDBid NodeType
=> CorpusId
-> IsTrash
-> [Text]
-> Cmd err Int
......@@ -77,7 +79,8 @@ searchCountInCorpus cId t q = runCountOpaQuery
$ intercalate " | "
$ map stemIt q
queryInCorpus :: CorpusId
queryInCorpus :: HasDBid NodeType
=> CorpusId
-> IsTrash
-> Text
-> O.Query FacetDocRead
......@@ -105,7 +108,8 @@ joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond
------------------------------------------------------------------------
searchInCorpusWithContacts
:: CorpusId
:: HasDBid NodeType
=> CorpusId
-> AnnuaireId
-> [Text]
-> Maybe Offset
......@@ -121,7 +125,8 @@ searchInCorpusWithContacts cId aId q o l _order =
$ map stemIt q
selectContactViaDoc
:: CorpusId
:: HasDBid NodeType
=> CorpusId
-> AnnuaireId
-> Text
-> QueryArr ()
......@@ -143,10 +148,11 @@ selectContactViaDoc cId aId q = proc () -> do
, toNullable $ pgInt4 1
)
selectGroup :: NodeId
-> NodeId
-> Text
-> Select FacetPairedReadNull
selectGroup :: HasDBid NodeType
=> NodeId
-> NodeId
-> Text
-> Select FacetPairedReadNull
selectGroup cId aId q = proc () -> do
(a, b, c, d) <- aggregate (p4 (groupBy, groupBy, groupBy, O.sum))
(selectContactViaDoc cId aId q) -< ()
......@@ -261,7 +267,8 @@ textSearchQuery = "SELECT n.id, n.hyperdata->'publication_year' \
-- Example:
-- textSearchTest :: ParentId -> TSQuery -> Cmd err [(Int, Value, Value, Value, Value, Maybe Int)]
-- textSearchTest pId q = textSearch q pId 5 0 Asc
textSearch :: TSQuery -> ParentId
textSearch :: HasDBid NodeType
=> TSQuery -> ParentId
-> Limit -> Offset -> Order
-> Cmd err [(Int,Value,Value,Value, Value, Maybe Int)]
textSearch q p l o ord = runPGSQuery textSearchQuery (q,p,p,typeId,ord,o,l)
......
src/Gargantext/Database/Admin/Types/Node.hs
View file @ 70057b4c
......@@ -42,7 +42,7 @@ import Test.QuickCheck.Instances.Time ()
import Text.Read (read)
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger, wellNamedSchema)
import Gargantext.Database.Prelude (fromField')
-- import Gargantext.Database.Prelude (fromField')
import Gargantext.Database.Schema.Node
import Gargantext.Prelude
......@@ -324,17 +324,16 @@ instance Arbitrary NodeType where
------------------------------------------------------------------------
-- Instances
------------------------------------------------------------------------
instance ToSchema Status where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "status_")
------------------------------------------------------------------------
{-
instance FromField (NodeId, Text)
where
fromField = fromField'
-}
------------------------------------------------------------------------
instance QueryRunnerColumnDefault PGTSVector (Maybe TSVector)
where
queryRunnerColumnDefault = fieldQueryRunnerColumn
......
src/Gargantext/Database/Prelude.hs
View file @ 70057b4c
......@@ -13,12 +13,12 @@ Portability : POSIX
module Gargantext.Database.Prelude where
-- import Control.Monad.Error.Class -- (MonadError(..), Error)
import Control.Exception
import Control.Lens (Getter, view)
-- import Control.Monad.Error.Class -- (MonadError(..), Error)
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Random
import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
import Data.ByteString.Char8 (hPutStrLn)
......@@ -31,6 +31,8 @@ import Data.Word (Word16)
import Database.PostgreSQL.Simple (Connection, connect)
import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
import Database.PostgreSQL.Simple.Internal (Field)
import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig())
import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery, PGJsonb, QueryRunnerColumnDefault)
import Opaleye.Aggregate (countRows)
import System.IO (FilePath)
......@@ -40,9 +42,6 @@ import qualified Data.ByteString as DB
import qualified Data.List as DL
import qualified Database.PostgreSQL.Simple as PGS
import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig())
-------------------------------------------------------
class HasConnectionPool env where
connPool :: Getter env (Pool Connection)
......
src/Gargantext/Database/Query/Table/Node.hs
View file @ 70057b4c
......@@ -59,7 +59,8 @@ runGetNodes = runOpaQuery
------------------------------------------------------------------------
-- | order by publication date
-- Favorites (Bool), node_ngrams
selectNodesWith :: ParentId -> Maybe NodeType
selectNodesWith :: HasDBid NodeType
=> ParentId -> Maybe NodeType
-> Maybe Offset -> Maybe Limit -> Query NodeRead
selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
--offset' maybeOffset $ limit' maybeLimit $ orderBy (asc (hyperdataDocument_Publication_date . node_hyperdata)) $ selectNodesWith' parentId typeId
......@@ -67,7 +68,8 @@ selectNodesWith parentId maybeNodeType maybeOffset maybeLimit =
$ orderBy (asc _node_id)
$ selectNodesWith' parentId maybeNodeType
selectNodesWith' :: ParentId -> Maybe NodeType -> Query NodeRead
selectNodesWith' :: HasDBid NodeType
=> ParentId -> Maybe NodeType -> Query NodeRead
selectNodesWith' parentId maybeNodeType = proc () -> do
node' <- (proc () -> do
row@(Node _ _ typeId _ parentId' _ _ _) <- queryNodeTable -< ()
......@@ -92,7 +94,7 @@ deleteNodes ns = mkCmd $ \conn ->
(\(Node n_id _ _ _ _ _ _ _) -> in_ ((map pgNodeId ns)) n_id)
-- TODO: NodeType should match with `a'
getNodesWith :: JSONB a => NodeId -> proxy a -> Maybe NodeType
getNodesWith :: (JSONB a, HasDBid NodeType) => NodeId -> proxy a -> Maybe NodeType
-> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
getNodesWith parentId _ nodeType maybeOffset maybeLimit =
runOpaQuery $ selectNodesWith parentId nodeType maybeOffset maybeLimit
......@@ -112,7 +114,8 @@ getNodesWithParentId n = runOpaQuery $ selectNodesWithParentID n'
-- | Given a node id, find it's closest parent of given type
-- NOTE: This isn't too optimal: can make successive queries depending on how
-- deeply nested the child is.
getClosestParentIdByType :: NodeId
getClosestParentIdByType :: HasDBid NodeType
=> NodeId
-> NodeType
-> Cmd err (Maybe NodeId)
getClosestParentIdByType nId nType = do
......@@ -134,17 +137,17 @@ getClosestParentIdByType nId nType = do
|]
------------------------------------------------------------------------
getDocumentsV3WithParentId :: NodeId -> Cmd err [Node HyperdataDocumentV3]
getDocumentsV3WithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocumentV3]
getDocumentsV3WithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
-- TODO: merge with getDocumentsWithParentId by having a class IsHyperdataDocument
getDocumentsWithParentId :: NodeId -> Cmd err [Node HyperdataDocument]
getDocumentsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataDocument]
getDocumentsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeDocument)
getListsModelWithParentId :: NodeId -> Cmd err [Node HyperdataModel]
getListsModelWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataModel]
getListsModelWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeModel)
getCorporaWithParentId :: NodeId -> Cmd err [Node HyperdataCorpus]
getCorporaWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataCorpus]
getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
------------------------------------------------------------------------
......@@ -158,21 +161,23 @@ selectNodesWithParentID n = proc () -> do
------------------------------------------------------------------------
-- | Example of use:
-- runCmdReplEasy (getNodesWithType NodeList (Proxy :: Proxy HyperdataList))
getNodesWithType :: (HasNodeError err, JSONB a) => NodeType -> proxy a -> Cmd err [Node a]
getNodesWithType :: (HasNodeError err, JSONB a, HasDBid NodeType) => NodeType -> proxy a -> Cmd err [Node a]
getNodesWithType nt _ = runOpaQuery $ selectNodesWithType nt
where
selectNodesWithType :: NodeType -> Query NodeRead
selectNodesWithType :: HasDBid NodeType
=> NodeType -> Query NodeRead
selectNodesWithType nt' = proc () -> do
row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
restrict -< tn .== (pgInt4 $ hasDBid nt')
returnA -< row
getNodesIdWithType :: HasNodeError err => NodeType -> Cmd err [NodeId]
getNodesIdWithType :: (HasNodeError err, HasDBid NodeType) => NodeType -> Cmd err [NodeId]
getNodesIdWithType nt = do
ns <- runOpaQuery $ selectNodesIdWithType nt
pure (map NodeId ns)
selectNodesIdWithType :: NodeType -> Query (Column PGInt4)
selectNodesIdWithType :: HasDBid NodeType
=> NodeType -> Query (Column PGInt4)
selectNodesIdWithType nt = proc () -> do
row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
restrict -< tn .== (pgInt4 $ hasDBid nt)
......@@ -199,20 +204,23 @@ getNodeWith nId _ = do
------------------------------------------------------------------------
-- | Sugar to insert Node with NodeType in Database
insertDefaultNode :: NodeType -> ParentId -> UserId -> Cmd err [NodeId]
insertDefaultNode :: HasDBid NodeType
=> NodeType -> ParentId -> UserId -> Cmd err [NodeId]
insertDefaultNode nt p u = insertNode nt Nothing Nothing p u
insertNode :: NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
insertNode :: HasDBid NodeType
=> NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> Cmd err [NodeId]
insertNode nt n h p u = insertNodesR [nodeW nt n h p u]
nodeW :: NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
nodeW :: HasDBid NodeType
=> NodeType -> Maybe Name -> Maybe DefaultHyperdata -> ParentId -> UserId -> NodeWrite
nodeW nt n h p u = node nt n' h' (Just p) u
where
n' = fromMaybe (defaultName nt) n
h' = maybe (defaultHyperdata nt) identity h
------------------------------------------------------------------------
node :: (ToJSON a, Hyperdata a)
node :: (ToJSON a, Hyperdata a, HasDBid NodeType)
=> NodeType
-> Name
-> a
......@@ -265,7 +273,8 @@ insertNodesWithParentR pid ns = insertNodesR (set node_parentId (pgNodeId <$> pi
-- currently this function removes the child relation
-- needs a Temporary type between Node' and NodeWriteT
node2table :: UserId -> Maybe ParentId -> Node' -> NodeWrite
node2table :: HasDBid NodeType
=> UserId -> Maybe ParentId -> Node' -> NodeWrite
node2table uid pid (Node' nt txt v []) = Node Nothing Nothing (pgInt4 $ hasDBid nt) (pgInt4 uid) (fmap pgNodeId pid) (pgStrictText txt) Nothing (pgStrictJSONB $ cs $ encode v)
node2table _ _ (Node' _ _ _ _) = panic "node2table: should not happen, Tree insert not implemented yet"
......@@ -284,7 +293,8 @@ mkNodeR :: [NodeWrite] -> Cmd err [NodeId]
mkNodeR ns = mkCmd $ \conn -> runInsert_ conn $ Insert nodeTable ns (rReturning _node_id) Nothing
------------------------------------------------------------------------
childWith :: UserId -> ParentId -> Node' -> NodeWrite
childWith :: HasDBid NodeType
=> UserId -> ParentId -> Node' -> NodeWrite
childWith uId pId (Node' NodeDocument txt v []) = node2table uId (Just pId) (Node' NodeDocument txt v [])
childWith uId pId (Node' NodeContact txt v []) = node2table uId (Just pId) (Node' NodeContact txt v [])
childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a child"
......@@ -298,7 +308,7 @@ data CorpusType = CorpusDocument | CorpusContact
class MkCorpus a
where
mk :: Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
mk :: HasDBid NodeType => Maybe Name -> Maybe a -> ParentId -> UserId -> Cmd err [NodeId]
instance MkCorpus HyperdataCorpus
where
......@@ -312,7 +322,7 @@ instance MkCorpus HyperdataAnnuaire
mk n (Just h) p u = insertNode NodeAnnuaire n (Just $ DefaultAnnuaire h) p u
getOrMkList :: HasNodeError err
getOrMkList :: (HasNodeError err, HasDBid NodeType)
=> ParentId
-> UserId
-> Cmd err ListId
......@@ -322,11 +332,11 @@ getOrMkList pId uId =
mkList' pId' uId' = maybe (nodeError MkNode) pure . headMay =<< insertDefaultNode NodeList pId' uId'
-- | TODO remove defaultList
defaultList :: HasNodeError err => CorpusId -> Cmd err ListId
defaultList :: (HasNodeError err, HasDBid NodeType) => CorpusId -> Cmd err ListId
defaultList cId =
maybe (nodeError NoListFound) (pure . view node_id) . headMay =<< getListsWithParentId cId
getListsWithParentId :: NodeId -> Cmd err [Node HyperdataList]
getListsWithParentId :: HasDBid NodeType => NodeId -> Cmd err [Node HyperdataList]
getListsWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeList)
src/Gargantext/Database/Query/Table/Node/UpdateOpaleye.hs
View file @ 70057b4c
......@@ -17,6 +17,7 @@ module Gargantext.Database.Query.Table.Node.UpdateOpaleye
import Opaleye
import Data.Aeson (encode, ToJSON)
import Gargantext.Core
import Gargantext.Prelude
import Gargantext.Database.Schema.Node
import Gargantext.Database.Admin.Types.Node
......@@ -42,6 +43,7 @@ updateHyperdataQuery i h = Update
updateNodesWithType :: ( HasNodeError err
, JSONB a
, ToJSON a
, HasDBid NodeType
) => NodeType -> proxy a -> (a -> a) -> Cmd err [Int64]
updateNodesWithType nt p f = do
ns <- getNodesWithType nt p
......@@ -50,9 +52,10 @@ updateNodesWithType nt p f = do
-- | In case the Hyperdata Types are not compatible
updateNodesWithType_ :: ( HasNodeError err
, JSONB a
, ToJSON a
) => NodeType -> a -> Cmd err [Int64]
, JSONB a
, ToJSON a
, HasDBid NodeType
) => NodeType -> a -> Cmd err [Int64]
updateNodesWithType_ nt h = do
ns <- getNodesIdWithType nt
mapM (\n -> updateHyperdata n h) ns
......
src/Gargantext/Database/Query/Table/Node/User.hs
View file @ 70057b4c
......@@ -13,6 +13,7 @@ module Gargantext.Database.Query.Table.Node.User
where
import Data.Maybe (fromMaybe)
import Gargantext.Core
import Gargantext.Core.Types (Name)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..), defaultHyperdataUser)
import Gargantext.Database.Admin.Types.Node (Node, NodeId(..), UserId, NodeType(..), pgNodeId)
......@@ -28,7 +29,7 @@ getNodeUser nId = do
fromMaybe (panic $ "Node does not exist: " <> (cs $ show nId)) . headMay
<$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
nodeUserW :: Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite
nodeUserW :: HasDBid NodeType => Maybe Name -> Maybe HyperdataUser -> UserId -> NodeWrite
nodeUserW maybeName maybeHyperdata = node NodeUser name user Nothing
where
name = maybe "User" identity maybeName
......
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