Verified Commit 9be580a4 authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski

Merge branch 'dev' into 471-dev-node-multiterms

parents a059fd1c 61aac410
Pipeline #7789 passed with stages
in 41 minutes and 44 seconds
## Version 0.0.7.4.8
* [BACK][UPGRADE][Upgrade GHC to 9.6.x (#436)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/436) and [Try to drop dependency on `accelerate-llvm` and the entire `llvm` stack (#291)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/291)
* [BACK][FEAT][Implement temporary file storage (#444)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/444)
* [BACK/FRONT][FEAT][Import/export in SQLite format (#362)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/362)
* [DOC][README][README: add info about system postgresql configuration](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/403)
* [FRONT][FIX][`./install` doesn't work on Darwin (#671)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/671)
* [BACK][FIX][Fix `start-all` so that it throws exception when a subprocess fails (#463)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/463)
* [FRONT][FIX][[corpus] create list if it doesn't exist](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/merge_requests/506)
* [FRONT][FIX][Upload file sends 'Nothing' as language which results in 400 error from backend (#736)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/736)
* [BACK][FIX][Convert non-transactional GGTX DB queries into transactions (#411)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/466) and [ACID properties of DB operations](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/411)
* [BACK][FIX][Proper (and thread-safe) implementation for `withSeed`](https://gitlab.iscpif.fr/gargantext/haskell-igraph/merge_requests/6)
* [FRONT][FEAT][Share link copy to clipboard](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/719)
* [BACK][FIX][Relax dependency bounds](https://gitlab.iscpif.fr/gargantext/haskell-igraph/merge_requests/8)
* [BACK][UPGRADE][Upgrade IGraph](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/411)
* [FRONT][FEAT][Feature flags hide](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/merge_requests/511)
* [BACK][FIX][Fix a bug in `buildPatterns` and friends](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/413)
* [BACK/FRONT][OPTIM][Resolve "Display graph parameters in legend"](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/merge_requests/510)
* [BACK][FIX][Separate ngram extraction from document insertion](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/415)
* [BACK][REFACT][API refactorings (#467)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/467)
* [BACK/FRONT][FIX][[graphql] simplify and_logic for get contexts for ngrams](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/merge_requests/515)
* [FRONT][OPTIM][[Node Graph] CSS improvements on the legend tab (#743)](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/issues/743)
* [BACK][FIX][ Have `extractNgramsFromDocument` catch the right exception in case extraction fails](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/419)
* [FRONT][FIX][[Node terms] Show related docs for children terms as well](https://gitlab.iscpif.fr/gargantext/purescript-gargantext/merge_requests/516)
* [BACK][FIX][Fix bug in DB transaction rollbacks in the presence of domain-specific errors](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/420)
* [BACK][FIX][Resolve "Error uploading zip file on dev"](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/417)
* [BACK][OPTIM][Port all the tasty specs to hspec](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/423)
* [BACK][UPGRADE][[openalex] make search act similar to the one on openalex web](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/425)
* [BACK][FIX][Proper incremental TSV parser](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/merge_requests/402)
* [BACK][OPTIM][Remove useless ghc dependency from tree](https://gitlab.iscpif.fr/gargantext/crawlers/pubmed/merge_requests/14)
## Version 0.0.7.4.7
* [BACK][FIX][Adjust the output of the UpdateList tests (#460)](https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/460)
......
......@@ -11,10 +11,7 @@ Import a corpus binary.
-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
module CLI.Ini where
......@@ -104,12 +101,12 @@ convertConfigs ini@(Ini.GargConfig { .. }) iniMail nlpConfig connInfo =
mkFrontendConfig :: Ini.GargConfig -> CTypes.FrontendConfig
mkFrontendConfig (Ini.GargConfig { .. }) =
CTypes.FrontendConfig { _fc_url = _gc_url
CTypes.FrontendConfig { _fc_external_url = _fc_url
, _fc_internal_url = _fc_url
, _fc_directory = "./purescript-gargantext/dist"
, _fc_backend_name = _gc_backend_name
, _fc_url_backend_api = _gc_url_backend_api
, _fc_cors
, _fc_microservices
, _fc_appPort = 3000
, _fc_cookie_settings = CTypes.defaultCookieSettings }
where
_fc_cors = CTypes.CORSSettings { _corsAllowedOrigins = [
......@@ -138,6 +135,10 @@ mkFrontendConfig (Ini.GargConfig { .. }) =
case parseBaseUrl (T.unpack url) of
Nothing -> panicTrace $ "Cannot parse base url for: " <> url
Just b -> CTypes.CORSOrigin b
_fc_url =
case parseBaseUrl (T.unpack _gc_url) of
Nothing -> panicTrace $ "Cannot parse base url for: " <> _gc_url
Just b -> b
defaultNotificationsConfig :: CTypes.NotificationsConfig
defaultNotificationsConfig =
......
......@@ -77,13 +77,11 @@ serverParser = hsubparser (
start_p :: Parser CLIServer
start_p = fmap CLIS_start $ ServerArgs
<$> mode_p
<*> port_p
<*> settings_p
start_all_p :: Parser CLIServer
start_all_p = fmap CLIS_startAll $ ServerArgs
<$> mode_p
<*> port_p
<*> settings_p
mode_p :: Parser Mode
......@@ -92,21 +90,13 @@ mode_p = option auto ( long "mode"
<> metavar "M"
<> help "Possible modes: Dev | Mock | Prod" )
port_p :: Parser Int
port_p = option auto ( long "port"
<> short 'p'
<> metavar "P"
<> showDefault
<> value 8008
<> help "Port" )
version_p :: Parser CLIServer
version_p = pure CLIS_version
startServerCLI :: Logger IO -> ServerArgs -> IO ()
startServerCLI ioLogger (ServerArgs { .. }) = do
logMsg ioLogger INFO $ "starting server, mode: " <> show server_mode <> ", port: " <> show server_port <> ", config: " <> _SettingsFile server_toml
logMsg ioLogger INFO $ "starting server, mode: " <> show server_mode <> ", config: " <> _SettingsFile server_toml
-- Sets the locale to avoid encoding issues like in #284.
setLocaleEncoding utf8
......@@ -114,4 +104,4 @@ startServerCLI ioLogger (ServerArgs { .. }) = do
logMsg ioLogger ERROR "Mock mode not supported!"
exitFailure
startGargantext server_mode server_port server_toml
startGargantext server_mode server_toml
......@@ -100,7 +100,6 @@ data CLIServer
data ServerArgs = ServerArgs
{ server_mode :: !Mode
, server_port :: !Int
, server_toml :: !SettingsFile }
deriving (Show, Eq)
......
......@@ -40,7 +40,8 @@ services:
POSTGRES_PASSWORD: C8kdcUrAQy66U
POSTGRES_DB: gargandbV5
volumes:
- garg-pgdata14:/var/lib/postgresql/data
# - garg-pgdata14:/var/lib/postgresql/data
- docker_garg-pgdata14:/var/lib/postgresql/data
- ../:/gargantext
- ../dbs:/dbs
- ../postgres/schema.sql:/docker-entrypoint-initdb.d/schema.sql:ro
......@@ -71,6 +72,8 @@ services:
volumes:
#garg-pgdata:
garg-pgdata14:
# garg-pgdata14:
docker_garg-pgdata14:
external: true
js-cache:
pgadmin:
[frontend]
# Main url serving the FrontEnd (public URL)
external_url = "http://localhost:8008"
# Main url serving the FrontEnd
url = "http://localhost"
# host/port where the GarganText server will bind to
internal_url = "http://localhost:8008"
backend_name = "localhost"
# Location of the frontend code. This will be served at the root of
# the path (e.g. index.html)
directory = "./purescript-gargantext/dist"
# Main API url serving the BackEnd
url_backend_api = "http://localhost:8008/api/v1.0"
backend_name = "localhost"
jwt_settings = "TODO"
......
......@@ -5,7 +5,7 @@ cabal-version: 3.4
-- see: https://github.com/sol/hpack
name: gargantext
version: 0.0.7.4.7
version: 0.0.7.4.8
synopsis: Search, map, share
description: Please see README.md
category: Data
......@@ -570,6 +570,7 @@ library
, json-stream ^>= 0.4.2.4
, lens >= 5.2.2 && < 5.3
, lens-aeson < 1.3
, list-zipper
, massiv < 1.1
, matrix ^>= 0.3.6.1
, mime-mail >= 0.5.1
......
# https://nix.dev/tutorials/first-steps/towards-reproducibility-pinning-nixpkgs.html
{ pkgs ? import
(if builtins.elem builtins.currentSystem [ "x86_64-darwin" "aarch64-darwin" ]
then ./pinned-25.05.darwin.nix
......@@ -7,19 +8,20 @@
rec {
inherit pkgs;
ghc966 = pkgs.haskell.compiler.ghc966;
cabal_install = pkgs.haskell.lib.compose.justStaticExecutables pkgs.haskell.packages.ghc966.cabal-install;
ghcVersion = "ghc966";
gargGhc = pkgs.haskell.compiler.${ghcVersion};
cabal_install = pkgs.haskell.lib.compose.justStaticExecutables pkgs.haskell.packages.${ghcVersion}.cabal-install;
graphviz = pkgs.callPackage ./graphviz.nix { };
igraph_0_10_4 = pkgs.callPackage ./igraph.nix { };
corenlp = pkgs.callPackage ./corenlp.nix { }; # 4.5.8
cabal2stack = pkgs.callPackage ./cabal2stack.nix { ghc = ghc966; };
corenlp = pkgs.callPackage ./corenlp.nix { }; # 4.5.9
cabal2stack = pkgs.callPackage ./cabal2stack.nix { ghc = gargGhc; };
nng_notls = pkgs.nng.overrideAttrs (old: {
cmakeFlags = (old.cmakeFlags or [ ]) ++ [ "-DNNG_ENABLE_TLS=OFF" ];
});
hsBuildInputs = [
ghc966
gargGhc
cabal_install
pkgs.haskellPackages.alex
pkgs.haskellPackages.happy
......
......@@ -49,7 +49,7 @@ import Gargantext.API.Routes.Named (API)
import Gargantext.API.Routes.Named.EKG (EkgAPI)
import Gargantext.API.Server.Named (server)
import Gargantext.Core.Config
import Gargantext.Core.Config.Types (CORSOrigin(..), CORSSettings, MicroServicesProxyStatus(..), NotificationsConfig(..), PortNumber, SettingsFile(..), corsAllowedOrigins, fc_appPort, fc_cors, fc_cookie_settings, microServicesProxyStatus)
import Gargantext.Core.Config.Types (CORSOrigin(..), CORSSettings, MicroServicesProxyStatus(..), NotificationsConfig(..), PortNumber, SettingsFile(..), corsAllowedOrigins, fc_cors, fc_cookie_settings, fc_internal_url, microServicesProxyStatus)
import Gargantext.Core.Config.Utils (readConfig)
import Gargantext.Core.Notifications (withNotifications)
import Gargantext.Database.Prelude qualified as DB
......@@ -62,21 +62,20 @@ import Network.Wai.Handler.Warp hiding (defaultSettings)
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.RequestLogger (logStdout)
import Servant hiding (Header)
import Servant.Client.Core.BaseUrl (showBaseUrl)
import Servant.Client.Core.BaseUrl (showBaseUrl, baseUrlPort)
import System.Clock qualified as Clock
import System.Cron.Schedule qualified as Cron
-- | startGargantext takes as parameters port number and Toml file.
startGargantext :: Mode -> PortNumber -> SettingsFile -> IO ()
startGargantext mode port sf@(SettingsFile settingsFile) = do
config <- readConfig sf <&> (gc_frontend_config . fc_appPort) .~ port
startGargantext :: Mode -> SettingsFile -> IO ()
startGargantext mode sf@(SettingsFile settingsFile) = do
config <- readConfig sf
withLoggerIO (config ^. gc_logging) $ \logger -> do
when (port /= config ^. gc_frontend_config . fc_appPort) $
panicTrace "TODO: conflicting settings of port"
withNotifications config $ \dispatcher -> do
env <- newEnv logger config dispatcher
let fc = env ^. env_config . gc_frontend_config
let proxyStatus = microServicesProxyStatus fc
let port = baseUrlPort (fc ^. fc_internal_url)
runDbCheck env
startupInfo config port proxyStatus
app <- makeApp env
......
......@@ -16,9 +16,10 @@ Loads all static file for the front-end.
---------------------------------------------------------------------
module Gargantext.API.Admin.FrontEnd where
import GHC.IO (FilePath)
import Servant
type FrontEndAPI = Raw
frontEndServer :: Server FrontEndAPI
frontEndServer = serveDirectoryFileServer "./purescript-gargantext/dist"
frontEndServer :: FilePath -> Server FrontEndAPI
frontEndServer path = serveDirectoryFileServer path
This diff is collapsed.
......@@ -10,10 +10,17 @@ Portability : POSIX
-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.API.Ngrams.NgramsTree
where
( -- * Types
NgramsForest(..)
, NgramsTree
, GeneralisedNgramsTree(..)
-- * Construction
, toNgramsTree
, toNgramsForest
) where
import Data.Aeson
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
import Data.List qualified as List
......@@ -23,41 +30,80 @@ import Data.Tree ( Tree(Node), unfoldForest )
import Gargantext.API.Ngrams.Types
import Gargantext.Core.Types.Main ( ListType(..) )
import Gargantext.Database.Admin.Types.Node ( NodeId )
import Gargantext.Core.Utils.Prefix (unPrefix, unPrefixSwagger)
import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
import Gargantext.Prelude
import Test.QuickCheck ( Arbitrary(arbitrary) )
type Children = Text
type Root = Text
-- | Ngrams forms a forest, i.e. a set of trees, each tree represents a strong grouping
-- between terms. Each tree has a root and some children, of arbitrary depth. We use
-- this data structure internally to represent ngrams tables in a principled way, and later
-- we \"render\" them back into an 'NgramsTable' and/or a set of ngrams elements, where
-- each 'NgramElement' is a standalone tree.
--
-- Properties:
--
-- * Aciclic: each tree is a DAG, and therefore there must be no cycles within the tree,
-- and no cycles between trees in the forest.
--
-- /NOTE/: An 'NgramsForest' and a 'GeneralisedNgramsTree' are essentially isomorphic to the \"Tree\"
-- and \"Forest\" types from the \"containers\" library, but our version allows storing both a label and
-- a value for each node.
newtype NgramsForest =
NgramsForest { getNgramsForest :: [NgramsTree] }
deriving (Show, Eq, Ord)
type NgramsTree = GeneralisedNgramsTree Text Int
data NgramsTree = NgramsTree { mt_label :: Text
, mt_value :: Double
, mt_children :: [NgramsTree]
}
deriving (Generic, Show, Eq)
-- | Models a general ngram tree polymorphic over a label 'l' and a measure 'm'.
data GeneralisedNgramsTree l m =
GeneralisedNgramsTree { mt_label :: l
, mt_value :: m
, mt_children :: [GeneralisedNgramsTree l m]
}
deriving (Generic, Show, Eq, Ord)
toNgramsTree :: Tree (NgramsTerm,Double) -> NgramsTree
toNgramsTree (Node (NgramsTerm l,v) xs) = NgramsTree l v (map toNgramsTree xs)
instance (ToJSON l, ToJSON m) => ToJSON (GeneralisedNgramsTree l m) where
toJSON (GeneralisedNgramsTree l m children) =
object [ "label" .= toJSON l
, "value" .= toJSON m
, "children" .= toJSON children
]
deriveJSON (unPrefix "mt_") ''NgramsTree
instance (FromJSON l, FromJSON m) => FromJSON (GeneralisedNgramsTree l m) where
parseJSON = withObject "NgramsTree" $ \o -> do
mt_label <- o .: "label"
mt_value <- o .: "value"
mt_children <- o .: "children"
pure $ GeneralisedNgramsTree{..}
instance ToSchema NgramsTree where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "mt_")
instance Arbitrary NgramsTree
where
arbitrary = NgramsTree <$> arbitrary <*> arbitrary <*> arbitrary
arbitrary = GeneralisedNgramsTree <$> arbitrary <*> arbitrary <*> arbitrary
--
-- Constructing trees and forests
--
-- | Given a 'Tree' from the \"containers\" library that has an 'NgramsTerm' and a score at the leaves,
-- converts it into a gargantext 'NgramsTree' tree.
toNgramsTree :: Tree (NgramsTerm,Int) -> NgramsTree
toNgramsTree (Node (NgramsTerm l,v) xs) = GeneralisedNgramsTree l v (map toNgramsTree xs)
toTree :: ListType
-> HashMap NgramsTerm (Set NodeId)
-> HashMap NgramsTerm NgramsRepoElement
-> [NgramsTree]
toTree lt vs m = map toNgramsTree $ unfoldForest buildNode roots
-- | Given a 'ListType', which informs which category of terms we want to focus on (stop, map, candidate)
-- and two hashmaps mapping an 'NgramsTerm' to their values, builds an 'NgramsForest'.
toNgramsForest :: ListType
-> HashMap NgramsTerm (Set NodeId)
-> HashMap NgramsTerm NgramsRepoElement
-> NgramsForest
toNgramsForest lt vs m = NgramsForest $ map toNgramsTree $ unfoldForest buildNode roots
where
buildNode r = maybe ((r, value r),[])
(\x -> ((r, value r), mSetToList $ _nre_children x))
(HashMap.lookup r m)
value l = maybe 0 (fromIntegral . Set.size) $ HashMap.lookup l vs
value l = maybe 0 Set.size $ HashMap.lookup l vs
rootsCandidates :: [NgramsTerm]
rootsCandidates = catMaybes
......
......@@ -28,11 +28,12 @@ import Gargantext.API.Node.Corpus.Export.Types ( Corpus(..), CorpusSQLite(..) )
import Gargantext.API.Node.Corpus.Export.Utils (getContextNgrams, mkCorpusSQLite, mkCorpusSQLiteData)
import Gargantext.API.Node.Document.Export.Types qualified as DocumentExport
import Gargantext.API.Prelude (IsGargServer)
import Gargantext.API.Routes.Named.Corpus qualified as Named
import Gargantext.Core.NodeStory
import Gargantext.Core.Text.Ngrams (NgramsType(..))
import Gargantext.Core.Types.Main ( ListType(MapTerm) )
import Gargantext.Database.Admin.Types.Hyperdata.Document ( HyperdataDocument(..) )
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Admin.Types.Node (Context, CorpusId, ListId, context2node, nodeId2ContextId)
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node ( defaultList )
import Gargantext.Database.Query.Table.NodeContext (selectDocNodes)
......@@ -41,7 +42,6 @@ import Gargantext.Prelude hiding (hash)
import Gargantext.Prelude.Crypto.Hash (hash)
import Servant (Headers, Header, addHeader)
import Servant.Server.Generic (AsServerT)
import qualified Gargantext.API.Routes.Named.Corpus as Named
--------------------------------------------------
-- | Hashes are ordered by Set
......
......@@ -87,3 +87,4 @@ data CorpusSQLiteData =
, _csd_stop_context_ngrams :: Map ContextId (Set NgramsTerm)
, _csd_candidate_context_ngrams :: Map ContextId (Set NgramsTerm)
} deriving (Show, Eq, Generic)
......@@ -141,7 +141,9 @@ mkCorpusSQLite (CorpusSQLiteData { .. }) = withTempSQLiteDir $ \(fp, _fname, fpa
S.withConnection fpath $ \conn -> do
-- better performance
-- https://kerkour.com/sqlite-for-servers
S.execute_ conn "PRAGMA journal_mode = WAL"
S.execute_ conn "PRAGMA journal_mode = WAL" -- overall, a good idea for sqlite
S.execute_ conn "PRAGMA synchronous = NORMAL" -- faster writes
S.execute_ conn "PRAGMA cache_size = 1000000" -- better memory usage
S.execute_ conn "CREATE TABLE info (key, value);"
S.execute conn "INSERT INTO info (key, value) VALUES ('gargVersion', ?)" (S.Only $ showVersion _csd_version)
......@@ -179,6 +181,10 @@ mkCorpusSQLite (CorpusSQLiteData { .. }) = withTempSQLiteDir $ \(fp, _fname, fpa
, iso8601Show ctxDate
, Aeson.encode ctxHyperdata )) <$> _csd_contexts)
-- Force WAL checkpoint so we don't leave any data in the WAL log
-- (we only send the sqlite file, while WAL creates additional index files which would not be sent)
S.execute_ conn "PRAGMA wal_checkpoint(FULL)"
bsl <- BSL.readFile fpath
pure $ CorpusSQLite { _cs_bs = bsl }
......
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
......@@ -10,7 +10,7 @@ import Data.Validity qualified as V
import Gargantext.API.Prelude (IsGargServer)
import Gargantext.API.Routes.Named.Share qualified as Named
import Gargantext.Core.Config (GargConfig, gc_frontend_config, HasConfig(hasConfig))
import Gargantext.Core.Config.Types (fc_appPort, fc_url)
import Gargantext.Core.Config.Types (getPublicUrl)
import Gargantext.Core.Types (NodeType, NodeId, unNodeId, _ValidationError)
import Gargantext.Database.Prelude (IsDBEnvExtra)
import Gargantext.Prelude
......@@ -37,18 +37,21 @@ get_url :: Maybe NodeType
-> GargConfig
-> Either String Named.ShareLink
get_url nt id gc = do
let urlHost = T.unpack $ gc ^. gc_frontend_config . fc_url
let urlPort = gc ^. gc_frontend_config . fc_appPort
let fc = gc ^. gc_frontend_config
-- let urlHost = T.unpack $ gc ^. gc_frontend_config . fc_url
-- let urlPort = gc ^. gc_frontend_config . fc_appPort
t <- maybe (Left "Invalid node Type") Right nt
i <- maybe (Left "Invalid node ID") Right id
let sharePart = "/#/share/" <> show t <> "/" <> show (unNodeId i)
-- Include the port the server is running on if this is
-- localhost, so that share URLs would work out of the box.
let !rawURL
| "localhost" `isInfixOf` urlHost
= urlHost <> ":" <> show urlPort <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
| otherwise
= urlHost <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
let !rawURL = T.unpack $ (getPublicUrl fc) <> sharePart
-- | "localhost" `isInfixOf` urlHost
-- = urlHost <> ":" <> show urlPort <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
-- | otherwise
-- = urlHost <> "/#/share/" <> show t <> "/" <> show (unNodeId i)
maybe (Left $ "Couldn't construct a valid share URL from '" <> rawURL <> "'")
(Right . Named.ShareLink)
(parseURI rawURL)
......@@ -16,7 +16,7 @@ import Gargantext.API.Admin.EnvTypes (Env)
import Gargantext.API.Admin.FrontEnd (frontEndServer)
import Gargantext.API.Auth.PolicyCheck ()
import Gargantext.API.Errors
import Gargantext.API.GraphQL as GraphQL
import Gargantext.API.GraphQL as GraphQL ( GraphQLAPI, api )
import Gargantext.API.Prelude (GargM)
import Gargantext.API.Routes.Named
import Gargantext.API.Server.Named.Public (serverPublicGargAPI)
......@@ -24,7 +24,7 @@ import Gargantext.API.Swagger (openApiDoc)
import Gargantext.API.ThrowAll (serverPrivateGargAPI)
import Gargantext.Core.Notifications.Dispatcher.WebSocket qualified as Dispatcher
import Gargantext.Core.Config (gc_frontend_config, hasConfig)
import Gargantext.Core.Config.Types (fc_url_backend_api)
import Gargantext.Core.Config.Types (fc_directory, fc_external_url)
import Gargantext.Prelude hiding (Handler, catch)
import Gargantext.System.Logging (logLocM, LogLevel(..))
import Paths_gargantext qualified as PG -- cabal magic build module
......@@ -40,7 +40,7 @@ serverGargAPI env
, gargForgotPasswordAsyncAPI = forgotPasswordAsync
, gargVersionAPI = gargVersion
, gargPrivateAPI = serverPrivateGargAPI
, gargPublicAPI = serverPublicGargAPI (env ^. hasConfig . gc_frontend_config . fc_url_backend_api)
, gargPublicAPI = serverPublicGargAPI (env ^. hasConfig . gc_frontend_config . fc_external_url)
}
where
gargVersion :: GargVersion (AsServerT (GargM Env BackendInternalError))
......@@ -66,7 +66,7 @@ server env =
-- (Proxy :: Proxy AuthContext)
(transformJSON errScheme)
Dispatcher.wsServer
, frontendAPI = frontEndServer
, frontendAPI = frontEndServer (env ^. hasConfig . gc_frontend_config . fc_directory)
}
where
transformJSON :: forall a. GargErrorScheme -> GargM Env BackendInternalError a -> Handler a
......
......@@ -9,7 +9,7 @@ import Gargantext.API.Errors.Types (BackendInternalError)
import Gargantext.API.Members (members)
import Gargantext.API.Ngrams.List qualified as List
import Gargantext.API.Node (annuaireNodeAPI, corpusNodeAPI, nodeAPI, nodeNodeAPI, nodesAPI, roots)
import Gargantext.API.Node.Contact as Contact
import Gargantext.API.Node.Contact as Contact ( contactAPI )
import Gargantext.API.Node.Corpus.Export qualified as CorpusExport
import Gargantext.API.Node.Corpus.Subcorpus qualified as Subcorpus
import Gargantext.API.Node.Document.Export (documentExportAPI)
......@@ -19,7 +19,7 @@ import Gargantext.API.Node.ShareURL ( shareURL )
import Gargantext.API.Prelude (GargM)
import Gargantext.API.Routes (addWithTempFileApi, addCorpusWithQuery)
import Gargantext.API.Routes.Named.Private qualified as Named
import Gargantext.API.Server.Named.Ngrams
import Gargantext.API.Server.Named.Ngrams ( apiNgramsTableDoc )
import Gargantext.API.Server.Named.Viz qualified as Viz
import Gargantext.Core.Types.Individu (User(..))
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataAny)
......
......@@ -4,9 +4,9 @@ module Gargantext.API.Server.Named.Public (
) where
import Control.Lens ((^?), _Just)
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as T
import Gargantext.API.Node.File (fileApi)
import Gargantext.API.Prelude (serverError, IsGargServer)
import Gargantext.API.Public.Types (PublicData(..))
......@@ -22,29 +22,30 @@ import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..))
import Gargantext.Database.Query.Table.NodeNode (selectPublicNodes)
import Gargantext.Database.Schema.Node ( NodePoly(..), node_date, node_hyperdata ) -- (NodePoly(..))
import Gargantext.Prelude
import Servant
import Servant ( ServerError(errBody), err405 )
import Servant.Client.Core.BaseUrl (BaseUrl(..), showBaseUrl)
import Servant.Server.Generic (AsServerT)
serverPublicGargAPI :: IsGargServer env err m => Text -> Named.GargPublicAPI (AsServerT m)
serverPublicGargAPI :: IsGargServer env err m => BaseUrl -> Named.GargPublicAPI (AsServerT m)
serverPublicGargAPI baseUrl = Named.GargPublicAPI $
Named.GargPublicAPI'
{ publicHomeAPI = api_home baseUrl
, publicNodeAPI = Named.NodeAPI api_node
{ publicHomeAPI = apiHome baseUrl
, publicNodeAPI = Named.NodeAPI apiNode
}
api_home :: IsGargServer env err m => Text -> Named.HomeAPI (AsServerT m)
api_home baseUrl = Named.HomeAPI $ runDBQuery $ catMaybes
apiHome :: IsGargServer env err m => BaseUrl -> Named.HomeAPI (AsServerT m)
apiHome baseUrl = Named.HomeAPI $ runDBQuery $ catMaybes
<$> map (toPublicData baseUrl)
<$> filterPublicDatas
<$> selectPublic
api_node :: IsGargServer env err m => NodeId -> Named.FileAPI (AsServerT m)
api_node nId = Named.FileAPI $ do
apiNode :: IsGargServer env err m => NodeId -> Named.FileAPI (AsServerT m)
apiNode nId = Named.FileAPI $ do
pubNodes <- runDBQuery publicNodes
-- TODO optimize with SQL
case Set.member nId pubNodes of
False -> serverError $ err405 { errBody = "Not allowed" }
True -> fileApi nId
(if Set.member nId pubNodes
then fileApi nId
else serverError $ err405 { errBody = "Not allowed" })
-------------------------------------------------------------------------
......@@ -61,7 +62,7 @@ filterPublicDatas :: [(Node HyperdataFolder, Maybe Int)]
filterPublicDatas datas =
map (\(n,mi) ->
let mi' = UnsafeMkNodeId <$> mi in
( _node_id n, (n, maybe [] (:[]) mi' ))
( _node_id n, (n, maybeToList mi' ))
) datas
& Map.fromListWith (\(n1,i1) (_n2,i2) -> (n1, i1 <> i2))
& Map.filter (not . null . snd)
......@@ -72,28 +73,29 @@ publicNodes :: HasNodeError err
publicNodes = do
candidates <- filterPublicDatas <$> selectPublicNodes
pure $ Set.fromList
$ List.concat
$ map (\(n, ns) -> (_node_id n) : ns) candidates
$ concatMap (\(n, ns) -> _node_id n : ns) candidates
-- http://localhost:8008/api/v1.0/node/23543/file/download<Paste>
-- http://localhost:8000/images/Gargantextuel-212x300.jpg
toPublicData :: Text -> (Node HyperdataFolder, [NodeId]) -> Maybe PublicData
toPublicData base (n , mn) = do
title <- (hd ^? (_Just . hf_data . cf_title))
abstract <- (hd ^? (_Just . hf_data . cf_desc ))
img <- (Just $ url' mn) -- "images/Gargantextuel-212x300.jpg"
url <- (Just $ url' mn)
toPublicData :: BaseUrl -> (Node HyperdataFolder, [NodeId]) -> Maybe PublicData
toPublicData baseUrl (n , mn) = do
title <- hd ^? (_Just . hf_data . cf_title)
abstract <- hd ^? (_Just . hf_data . cf_desc )
img <- Just $ url' mn -- "images/Gargantextuel-212x300.jpg"
url <- Just $ url' mn
date <- Just (show $ utc2year (n^.node_date))
database <- (hd ^? (_Just . hf_data . cf_query))
author <- (hd ^? (_Just . hf_data . cf_authors))
database <- hd ^? (_Just . hf_data . cf_query)
author <- hd ^? (_Just . hf_data . cf_authors)
pure $ PublicData { .. }
where
hd = head
$ filter (\(HyperdataField cd _ _) -> cd == JSON)
$ n^. (node_hyperdata . hc_fields)
url' :: [NodeId] -> Text
url' mn' = base
path :: [NodeId] -> Text
path mn' = "/api/v1.0"
<> "/public/"
<> (show $ (maybe 0 unNodeId $ head mn'))
<> show (maybe 0 unNodeId (head mn'))
<> "/file/download"
url' :: [NodeId] -> Text
url' mn' = T.pack $ showBaseUrl $ baseUrl { baseUrlPath = T.unpack $ path mn' }
......@@ -38,7 +38,7 @@ import Gargantext.API.Errors.Types
import Gargantext.API.Ngrams.Prelude (getNgramsList)
import Gargantext.API.Ngrams.Types (NgramsList)
import Gargantext.API.Node.Document.Export (get_document_json)
import Gargantext.API.Node.Document.Export.Types
import Gargantext.API.Node.Document.Export.Types ( DocumentExport(_de_documents) )
import Gargantext.API.Prelude (IsGargServer)
import Gargantext.API.Routes.Client (remoteImportClient)
import Gargantext.API.Routes.Named.Remote qualified as Named
......
......@@ -53,7 +53,7 @@ import Gargantext.Core.Config.Worker (WorkerSettings)
import Gargantext.Prelude
import Network.HTTP.Client qualified as HTTP
import Servant.Auth.Server (JWTSettings)
import Servant.Client (BaseUrl(..), Scheme(Http), parseBaseUrl)
import Servant.Client (BaseUrl(..))
import Toml.Schema
import Toml.Schema.FromValue (typeError)
......@@ -142,10 +142,8 @@ instance ToTable GargConfig where
mkProxyUrl :: GargConfig -> BaseUrl
mkProxyUrl GargConfig{..} =
case parseBaseUrl (T.unpack $ _fc_url _gc_frontend_config) of
Nothing -> BaseUrl Http "localhost" 80 ""
Just bh -> bh { baseUrlPort = _msProxyPort $ _fc_microservices _gc_frontend_config }
mkProxyUrl GargConfig{ _gc_frontend_config = cfg } =
(_fc_external_url cfg) { baseUrlPort = _msProxyPort $ _fc_microservices cfg }
class HasConfig env where
......
......@@ -27,13 +27,14 @@ module Gargantext.Core.Config.Types
, f_istex_url
, PortNumber
, FrontendConfig(..)
, fc_url
, fc_external_url
, fc_internal_url
, fc_backend_name
, fc_url_backend_api
, fc_directory
, fc_cors
, fc_microservices
, fc_appPort
, fc_cookie_settings
, getPublicUrl
, defaultCookieSettings
, MicroServicesProxyStatus(..)
, microServicesProxyStatus
......@@ -63,7 +64,7 @@ import Database.PostgreSQL.Simple qualified as PGS
import Gargantext.Prelude
import Servant.Auth.Server (CookieSettings(..), JWTSettings, XsrfCookieSettings(..), defaultJWTSettings, readKey, writeKey)
import Servant.Auth.Server qualified as SAuth
import Servant.Client.Core (BaseUrl, parseBaseUrl, showBaseUrl)
import Servant.Client.Core (BaseUrl(..), parseBaseUrl, showBaseUrl)
import System.Directory (doesFileExist)
import Toml
import Toml.Schema
......@@ -199,35 +200,49 @@ defaultCookieSettings = SAuth.defaultCookieSettings { cookieXsrfSetting = Just x
-- TODO jwtSettings = defaultJWTSettings
data FrontendConfig =
FrontendConfig { _fc_url :: !Text
FrontendConfig { _fc_external_url :: !BaseUrl
, _fc_internal_url :: !BaseUrl
, _fc_directory :: !FilePath
, _fc_backend_name :: !Text
, _fc_url_backend_api :: !Text
, _fc_cors :: !CORSSettings
, _fc_microservices :: !MicroServicesSettings
, _fc_appPort :: !PortNumber
, _fc_cookie_settings :: !CookieSettings
}
deriving (Generic, Show)
instance FromValue FrontendConfig where
fromValue = parseTableFromValue $ do
_fc_url <- reqKey "url"
_fc_external_url_txt <- reqKey "external_url"
_fc_external_url <-
case parseBaseUrl (T.unpack _fc_external_url_txt) of
Nothing -> fail "cannot parse fc_external_url"
Just b -> pure b
_fc_internal_url_txt <- reqKey "internal_url"
_fc_internal_url <-
case parseBaseUrl (T.unpack _fc_internal_url_txt) of
Nothing -> fail "cannot parse fc_internal_url"
Just b -> pure b
_fc_directory <- reqKey "directory"
_fc_backend_name <- reqKey "backend_name"
_fc_url_backend_api <- reqKey "url_backend_api"
_fc_cors <- reqKey "cors"
_fc_microservices <- reqKey "microservices"
let _fc_appPort = 3000
return $ FrontendConfig { _fc_cookie_settings = defaultCookieSettings, .. }
instance ToValue FrontendConfig where
toValue = defaultTableToValue
instance ToTable FrontendConfig where
toTable (FrontendConfig { .. }) = table [ "url" .= _fc_url
, "backend_name" .= _fc_backend_name
, "url_backend_api" .= _fc_url_backend_api
, "cors" .= _fc_cors
, "microservices" .= _fc_microservices ]
toTable (FrontendConfig { .. }) = table
[ "external_url" .= (T.pack $ showBaseUrl _fc_external_url)
, "internal_url" .= (T.pack $ showBaseUrl _fc_internal_url)
, "directory" .= _fc_directory
, "backend_name" .= _fc_backend_name
, "cors" .= _fc_cors
, "microservices" .= _fc_microservices ]
makeLenses ''FrontendConfig
getPublicUrl :: FrontendConfig -> Text
getPublicUrl (FrontendConfig { .. }) = T.pack $ showBaseUrl _fc_external_url
data MicroServicesProxyStatus
= PXY_enabled PortNumber
| PXY_disabled
......
......@@ -16,7 +16,7 @@ import Control.Monad.Trans.Control (MonadBaseControl)
import Data.List qualified as List
import Data.Text (splitOn)
import Gargantext.Core.Config (gc_frontend_config, HasConfig(..))
import Gargantext.Core.Config.Types (fc_url, fc_backend_name)
import Gargantext.Core.Config.Types (fc_backend_name, getPublicUrl)
import Gargantext.Core.Config.Mail (gargMail, GargMail(..), MailConfig)
import Gargantext.Core.Types.Individu
import Gargantext.Database.Schema.User (UserLight(..))
......@@ -75,7 +75,7 @@ mail mailCfg model = do
(m,u) = email_to model
subject = email_subject model
body = emailWith (ServerAddress (view (gc_frontend_config . fc_backend_name) cfg)
(view (gc_frontend_config . fc_url) cfg)) model
(getPublicUrl $ view gc_frontend_config cfg)) model
liftBase $ gargMail mailCfg (GargMail { gm_to = m
, gm_name = Just u
, gm_subject = subject
......
This diff is collapsed.
......@@ -28,8 +28,14 @@ get :: Text
-> IO (Either ClientError (Maybe Integer, ConduitT () HyperdataDocument IO ()))
get _email q lang mLimit = do
let limit = getLimit $ fromMaybe 1000 mLimit
let mFilter = (\l -> "language:" <> iso639ToText l) <$> lang
eRes <- OA.fetchWorksC Nothing mFilter $ Just $ Corpus.getRawQuery q
let filters =
[
-- see https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/490
-- see https://openalex.org/works?page=1&filter=title_and_abstract.search:brain:hawai
Just ("title_and_abstract.search:" <> Corpus.getRawQuery q)
, (\l -> "language:" <> iso639ToText l) <$> lang
]
eRes <- OA.fetchWorksC Nothing (Just $ T.intercalate "," $ catMaybes filters) Nothing
pure $ (\(len, docsC) -> (len, docsC .| takeC limit .| mapC toDoc)) <$> eRes
toDoc :: OA.Work -> HyperdataDocument
......
......@@ -17,7 +17,7 @@ import Data.List qualified as List
import Data.Map.Strict (toList)
import Data.Set qualified as Set
import Data.Vector qualified as V
import Gargantext.API.Ngrams.NgramsTree ( toTree, NgramsTree )
import Gargantext.API.Ngrams.NgramsTree ( toNgramsForest, NgramsTree, getNgramsForest )
import Gargantext.API.Ngrams.Tools ( filterListWithRoot, getListNgrams, getRepo, mapTermListRoot )
import Gargantext.API.Ngrams.Types ( NgramsTerm(NgramsTerm) )
import Gargantext.Core.NodeStory.Types ( NodeStoryEnv )
......@@ -91,4 +91,4 @@ treeData env cId nt lt = do
cs' <- HashMap.map (Set.map contextId2NodeId) <$> getContextsByNgramsOnlyUser cId (ls' <> ls) nt terms
m <- getListNgrams env ls nt
pure $ V.fromList $ toTree lt cs' m
pure $ V.fromList $ getNgramsForest $ toNgramsForest lt cs' m
......@@ -18,6 +18,7 @@
- "data-default-0.8.0.0"
- "data-default-class-0.2.0.0"
- "deferred-folds-0.9.18.7"
- "deriving-compat-0.6.7"
- "entropy-0.4.1.11"
- "file-embed-lzma-0.1"
- "foldl-1.4.18"
......@@ -38,6 +39,7 @@
- "jose-0.10.0.1"
- "language-c-0.10.0"
- "linear-1.23"
- "list-zipper-0.0.12"
- "massiv-1.0.4.1"
- "megaparsec-9.7.0"
- "microlens-th-0.4.3.16"
......@@ -367,7 +369,7 @@ flags:
gargantext:
"enable-benchmarks": false
"no-phylo-debug-logs": true
"test-crypto": false
"test-crypto": true
graphviz:
"test-parsing": false
hashable:
......@@ -540,8 +542,6 @@ flags:
transformers: true
tasty:
unix: true
"tasty-golden":
"build-example": false
"text-format":
developer: false
"text-metrics":
......
[frontend]
url = "http://localhost"
external_url = "http://localhost"
internal_url = "http://localhost"
directory = "./purescript-gargantext/dist"
backend_name = "localhost"
url_backend_api = "http://localhost:8008/api/v1.0"
jwt_settings = "TODO"
[frontend.cors]
......
......@@ -24,7 +24,7 @@ import Gargantext.API.Admin.EnvTypes (Env (..), env_dispatcher)
import Gargantext.API.Errors.Types
import Gargantext.API.Prelude
import Gargantext.Core.Config hiding (jwtSettings)
import Gargantext.Core.Config.Types (fc_appPort, jwtSettings)
import Gargantext.Core.Config.Types (jwtSettings, fc_external_url, fc_internal_url)
import Gargantext.Core.Notifications (withNotifications)
import Gargantext.Core.Types.Individu
import Gargantext.Database.Action.Flow
......@@ -37,7 +37,7 @@ import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node (getOrMkList)
import Gargantext.Database.Query.Tree.Root (MkCorpusUser(..))
import Gargantext.MicroServices.ReverseProxy (microServicesProxyApp)
import Gargantext.Prelude hiding (catches, Handler)
import Gargantext.Prelude hiding (catches, to, Handler)
import Gargantext.System.Logging
import Network.HTTP.Client.TLS (newTlsManager)
import Network.HTTP.Types
......@@ -48,6 +48,7 @@ import Network.Wai.Handler.Warp.Internal
import Network.WebSockets qualified as WS
import Prelude hiding (show)
import Servant.Auth.Client ()
import Servant.Client.Core (baseUrlPort)
import Test.Database.Setup (withTestDB)
import Test.Database.Types
import UnliftIO qualified
......@@ -72,7 +73,9 @@ newTestEnv :: TestEnv -> Logger (GargM Env BackendInternalError) -> Warp.Port ->
newTestEnv testEnv logger port = do
!manager_env <- newTlsManager
let config_env = test_config testEnv & (gc_frontend_config . fc_appPort) .~ port
let config_env = test_config testEnv
& (gc_frontend_config . fc_external_url) %~ (\b -> b { baseUrlPort = port })
& (gc_frontend_config . fc_internal_url) %~ (\b -> b { baseUrlPort = port })
-- dbParam <- pure $ testEnvToPgConnectionInfo testEnv
-- !pool <- newPool dbParam
......
This diff is collapsed.
......@@ -12,6 +12,7 @@ Portability : POSIX
{-# OPTIONS_GHC -fconstraint-solver-iterations=10 #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Instances
where
......@@ -382,15 +383,133 @@ instance Arbitrary DET.WSRequest where
, pure DET.WSDeauthorize ]
arbitraryNgramsTerm :: Gen Ngrams.NgramsTerm
arbitraryNgramsTerm = elements
[ "time"
, "year"
, "people"
, "way"
, "day"
, "man"
, "thing"
, "woman"
, "life"
, "child"
, "world"
, "school"
, "state"
, "family"
, "student"
, "group"
, "country"
, "problem"
, "hand"
, "part"
, "place"
, "case"
, "week"
, "company"
, "system"
, "program"
, "question"
, "work"
, "government"
, "number"
, "night"
, "point"
, "home"
, "water"
, "room"
, "mother"
, "area"
, "money"
, "story"
, "fact"
, "month"
, "lot"
, "right"
, "study"
, "book"
, "eye"
, "job"
, "word"
, "business"
, "issue"
, "side"
, "kind"
, "head"
, "house"
, "service"
, "friend"
, "father"
, "power"
, "hour"
, "game"
, "line"
, "end"
, "member"
, "law"
, "car"
, "city"
, "community"
, "name"
, "president"
, "team"
, "minute"
, "idea"
, "kid"
, "body"
, "information"
, "back"
, "parent"
, "face"
, "others"
, "level"
, "office"
, "door"
, "health"
, "person"
, "art"
, "war"
, "history"
, "party"
, "result"
, "change"
, "morning"
, "reason"
, "research"
, "girl"
, "guy"
, "moment"
, "air"
, "teacher"
, "force"
, "education"
]
-- Ngrams
instance Arbitrary a => Arbitrary (Ngrams.MSet a)
-- We cannot pick some completely arbitrary values for the ngrams terms,
-- see the rationale in the instance for 'NgramsElement'.
instance Arbitrary Ngrams.NgramsTerm where
arbitrary = Ngrams.NgramsTerm <$>
-- we take into accoutn the fact, that tojsonkey strips the text
(arbitrary `suchThat` (\t -> t == T.strip t))
arbitrary = arbitraryNgramsTerm
instance Arbitrary Ngrams.TabType where arbitrary = arbitraryBoundedEnum
instance Arbitrary Ngrams.NgramsElement where
arbitrary = elements [Ngrams.newNgramsElement Nothing "sport"]
-- We cannot pick some completely arbitrary values for the ngrams elements
-- because we still want to simulate potential hierarchies, i.e. forests of ngrams.
-- so we sample the ngrams terms from a selection, and we restrict the number of max
-- children for each 'NgramsElement' to the size parameter to not have very large trees.
arbitrary = do
_ne_ngrams <- arbitrary
_ne_size <- arbitrary
_ne_list <- arbitrary
_ne_occurrences <- arbitrary
_ne_root <- arbitrary `suchThat` (maybe True (\x -> x /= _ne_ngrams)) -- can't be root of itself
_ne_parent <- arbitrary `suchThat` (maybe True (\x -> x /= _ne_ngrams)) -- can't be parent of itself
_ne_children <- Ngrams.mSetFromList <$> (sized (\n -> vectorOf n arbitrary `suchThat` (\x -> _ne_ngrams `notElem` x))) -- can't be cyclic
pure Ngrams.NgramsElement{..}
instance Arbitrary Ngrams.NgramsTable where
arbitrary = pure ngramsMockTable
instance Arbitrary Ngrams.OrderBy where arbitrary = arbitraryBoundedEnum
......
{-# LANGUAGE TypeApplications #-}
module Test.Ngrams.Query (tests) where
module Test.Ngrams.Query (tests, mkMapTerm) where
import Control.Monad
import Data.Coerce
......
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module Test.Offline.Ngrams (tests) where
import Prelude
import Control.Lens
import Data.Map.Strict qualified as Map
import Data.Text qualified as T
import Gargantext.API.Ngrams (filterNgramsNodes, buildForest, destroyForest, pruneForest)
import Gargantext.API.Ngrams.Types
import Gargantext.API.Ngrams.Types qualified as NT
import Gargantext.Core
import Gargantext.Core.Text.Terms.Mono (isSep)
import Gargantext.Core.Text.Terms.WithList
import Gargantext.Core.Types
import Gargantext.Database.Action.Flow.Utils (docNgrams)
import Gargantext.Database.Schema.Context
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Schema.Context
import Test.HUnit
import Test.Hspec
import Test.Instances ()
import Test.Ngrams.Query (mkMapTerm)
import Test.QuickCheck
import Test.Hspec
import Control.Lens
import qualified Test.QuickCheck as QC
import Gargantext.Core.Text.Terms.Mono (isSep)
import Test.QuickCheck qualified as QC
import Data.Tree
import Text.RawString.QQ (r)
import Data.Char (isSpace)
import Data.Map.Strict (Map)
import Test.Hspec.QuickCheck (prop)
genScientificText :: Gen T.Text
......@@ -89,6 +101,31 @@ tests = describe "Ngrams" $ do
it "return results for non-empty input terms" $ property testBuildPatternsNonEmpty
describe "docNgrams" $ do
it "always matches if the input text contains any of the terms" $ property testDocNgramsOKMatch
describe "ngram forests" $ do
it "building a simple tree works" testBuildNgramsTree_01
it "building a complex tree works" testBuildNgramsTree_02
it "building a complex deep tree works" testBuildNgramsTree_03
it "pruning a simple tree works" testPruningNgramsForest_01
it "pruning a complex tree works" testPruningNgramsForest_02
prop "destroyForest . buildForest === id" buildDestroyForestRoundtrips
describe "hierarchical grouping" $ do
it "filterNgramsNodes with empty query is identity" testFilterNgramsNodesEmptyQuery
hierarchicalTableMap :: Map NgramsTerm NgramsElement
hierarchicalTableMap = Map.fromList [
("vehicle", mkMapTerm "vehicle" & ne_children .~ mSetFromList ["car"])
, ("car", mkMapTerm "car" & ne_root .~ Just "vehicle"
& ne_parent .~ Just "vehicle"
& ne_children .~ mSetFromList ["ford"])
, ("ford", mkMapTerm "ford" & ne_root .~ Just "vehicle"
& ne_parent .~ Just "car")
]
testFilterNgramsNodesEmptyQuery :: Assertion
testFilterNgramsNodesEmptyQuery = do
let input = hierarchicalTableMap
let actual = filterNgramsNodes (Just MapTerm) Nothing Nothing (const True) input
actual @?= input
testDocNgramsOKMatch :: Lang -> DocumentWithMatches -> Property
testDocNgramsOKMatch lang (DocumentWithMatches ts doc) =
......@@ -103,3 +140,166 @@ testBuildPatternsNonEmpty :: Lang -> NonEmptyList NgramsTermNonEmpty -> Property
testBuildPatternsNonEmpty lang ts =
let ts' = map (NT.NgramsTerm . unNgramsTermNonEmpty) $ getNonEmpty ts
in counterexample "buildPatterns returned no results" $ length (buildPatternsWith lang ts') > 0
newtype ASCIIForest = ASCIIForest String
deriving Eq
instance Show ASCIIForest where
show (ASCIIForest x) = x
compareForestVisually :: Forest NgramsElement -> String -> Property
compareForestVisually f expected =
let actual = init $ drawForest (map (fmap renderEl) f)
outermostIndentation = T.length . T.takeWhile isSpace . T.dropWhile (=='\n') . T.pack $ expected
in ASCIIForest actual === ASCIIForest (sanitiseDrawing outermostIndentation expected)
where
renderEl :: NgramsElement -> String
renderEl = T.unpack . unNgramsTerm . _ne_ngrams
toTextPaths :: String -> [T.Text]
toTextPaths = T.splitOn "\n" . T.strip . T.pack
sanitiseDrawing :: Int -> String -> String
sanitiseDrawing outermostIndentation =
let dropLayout t = case T.uncons t of
Just (' ', _) -> T.drop outermostIndentation t
_ -> t -- leave it be
in T.unpack . T.unlines . map dropLayout . toTextPaths
testBuildNgramsTree_01 :: Property
testBuildNgramsTree_01 =
let t1 = Map.fromList [ ( "foo", mkMapTerm "foo" & ne_children .~ mSetFromList ["bar"])
, ( "bar", mkMapTerm "bar" & ne_parent .~ Just "foo")
]
in (buildForest t1) `compareForestVisually` [r|
bar
foo
|
`- bar
|]
testBuildNgramsTree_02 :: Property
testBuildNgramsTree_02 =
buildForest hierarchicalTableMap `compareForestVisually` [r|
car
|
`- ford
ford
vehicle
|
`- car
|
`- ford
|]
testBuildNgramsTree_03 :: Property
testBuildNgramsTree_03 =
let input = Map.fromList [
("animalia", mkMapTerm "animalia" & ne_children .~ mSetFromList ["chordata"])
, ("chordata", mkMapTerm "chordata" & ne_root .~ Just "animalia"
& ne_parent .~ Just "animalia"
& ne_children .~ mSetFromList ["mammalia"])
, ("mammalia", mkMapTerm "mammalia" & ne_root .~ Just "animalia"
& ne_parent .~ Just "chordata"
& ne_children .~ mSetFromList ["carnivora", "primates"]
)
, ("carnivora", mkMapTerm "carnivora" & ne_root .~ Just "animalia"
& ne_parent .~ Just "mammalia"
& ne_children .~ mSetFromList ["felidae"]
)
, ("felidae", mkMapTerm "felidae" & ne_root .~ Just "animalia"
& ne_parent .~ Just "carnivora"
& ne_children .~ mSetFromList ["panthera"]
)
, ("panthera", mkMapTerm "panthera" & ne_root .~ Just "animalia"
& ne_parent .~ Just "felidae"
& ne_children .~ mSetFromList ["panthera leo", "panthera tigris"]
)
, ("panthera leo", mkMapTerm "panthera leo" & ne_root .~ Just "animalia"
& ne_parent .~ Just "pathera"
)
, ("panthera tigris", mkMapTerm "panthera tigris" & ne_root .~ Just "animalia"
& ne_parent .~ Just "panthera"
)
, ("panthera tigris", mkMapTerm "panthera tigris" & ne_root .~ Just "animalia"
& ne_parent .~ Just "panthera"
)
, ("primates", mkMapTerm "primates" & ne_root .~ Just "animalia"
& ne_parent .~ Just "mammalia"
& ne_children .~ mSetFromList ["hominidae"]
)
, ("hominidae", mkMapTerm "hominidae" & ne_root .~ Just "animalia"
& ne_parent .~ Just "primates"
& ne_children .~ mSetFromList ["homo"]
)
, ("homo", mkMapTerm "homo" & ne_root .~ Just "animalia"
& ne_parent .~ Just "hominidae"
& ne_children .~ mSetFromList ["homo sapiens"]
)
, ("homo sapies", mkMapTerm "homo sapiens" & ne_root .~ Just "animalia"
& ne_parent .~ Just "homo"
)
]
in pruneForest (buildForest input) `compareForestVisually` [r|
animalia
|
`- chordata
|
`- mammalia
|
+- carnivora
| |
| `- felidae
| |
| `- panthera
| |
| +- panthera leo
| |
| `- panthera tigris
|
`- primates
|
`- hominidae
|
`- homo
|]
newtype TableMapLockStep = TableMapLockStep { getTableMap :: Map NgramsTerm NgramsElement }
deriving (Show, Eq)
instance Arbitrary TableMapLockStep where
arbitrary = do
pairs <- map (\(k,v) -> (k, v & ne_ngrams .~ k)) <$> arbitrary
pure $ TableMapLockStep (Map.fromList pairs)
-- /PRECONDITION/: The '_ne_ngrams' field always matches the 'NgramsTerm', key of the map.
buildDestroyForestRoundtrips :: TableMapLockStep -> Property
buildDestroyForestRoundtrips (TableMapLockStep mp) =
(destroyForest . buildForest $ mp) === mp
testPruningNgramsForest_01 :: Property
testPruningNgramsForest_01 =
let t1 = Map.fromList [ ( "foo", mkMapTerm "foo" & ne_children .~ mSetFromList ["bar"])
, ( "bar", mkMapTerm "bar" & ne_parent .~ Just "foo")
]
in (pruneForest $ buildForest t1) `compareForestVisually` [r|
foo
|
`- bar
|]
testPruningNgramsForest_02 :: Property
testPruningNgramsForest_02 =
(pruneForest $ buildForest hierarchicalTableMap) `compareForestVisually` [r|
vehicle
|
`- car
|
`- ford
|]
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