Skip to content

haskell-gargantext
haskell-gargantext
Commit 7da5cfa2 authored by Quentin Lobbé's avatar Quentin Lobbé
Browse files
Options

Merge branch 'dev' into dev-phylo

parents ce0f0e64 1f9f3f09
Show whitespace changes
Inline Side-by-side
Showing with 1132 additions and 357 deletions
bin/gargantext-import/Main.hs
View file @ 7da5cfa2
......@@ -14,18 +14,21 @@ Import a corpus binary.
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Strict #-}
module Main where
import Control.Exception (finally)
import Servant (ServantErr)
import Gargantext.Prelude
import Gargantext.Database.Flow (flowCorpus)
import Gargantext.Database.Flow (FlowCmdM, flowCorpus)
import Gargantext.Text.Parsers (FileFormat(CsvHalFormat))
import Gargantext.Database.Utils (Cmd, connectGargandb, runCmdDevWith)
import Gargantext.Database.Types.Node (NodeId)
import Gargantext.Database.Utils (Cmd, )
import Gargantext.Database.Types.Node (CorpusId)
--import Gargantext.Database.Schema.User (insertUsers, gargantuaUser, simpleUser)
import Gargantext.API.Node () -- instances
import Gargantext.API.Settings (newDevEnvWith, runCmdDev, DevEnv)
import System.Environment (getArgs)
main :: IO ()
......@@ -34,11 +37,16 @@ main = do
{-let createUsers :: Cmd ServantErr Int64
createUsers = insertUsers [gargantuaUser,simpleUser]
_ <- runCmdDevWith iniPath createUsers
-}
let cmd :: Cmd ServantErr NodeId
cmd = flowCorpus CsvHalFormat corpusPath (cs name)
r <- runCmdDevWith iniPath cmd
let cmdCorpus :: forall m. FlowCmdM DevEnv ServantErr m => m CorpusId
cmdCorpus = flowCorpus CsvHalFormat corpusPath (cs name)
-- cmd = {-createUsers >>-} cmdCorpus
env <- newDevEnvWith iniPath
-- Better if we keep only one call to runCmdDev.
_ <- runCmdDev env cmdCorpus
pure ()
bin/gargantext-server/Main.hs
View file @ 7da5cfa2
......@@ -44,9 +44,13 @@ instance ParseField Mode
instance ParseFields Mode
data MyOptions w = MyOptions { run :: w ::: Mode <?> "Possible modes: Dev | Mock | Prod"
, port :: w ::: Maybe Int <?> "By default: 8008"
, ini :: w ::: Maybe Text <?> "Ini-file path of gargantext.ini"
data MyOptions w =
MyOptions { run :: w ::: Mode
<?> "Possible modes: Dev | Mock | Prod"
, port :: w ::: Maybe Int
<?> "By default: 8008"
, ini :: w ::: Maybe Text
<?> "Ini-file path of gargantext.ini"
}
deriving (Generic)
......@@ -54,30 +58,23 @@ instance ParseRecord (MyOptions Wrapped)
deriving instance Show (MyOptions Unwrapped)
main :: IO ()
main = do
MyOptions myMode myPort myIniFile <- unwrapRecord
"Gargantext: collaborative platform for text-mining"
"Gargantext server"
let myPort' = case myPort of
Just p -> p
Nothing -> 8008
let start = case myMode of
--Nothing -> startGargantext myPort' (unpack myIniFile')
Prod -> startGargantext myPort' (unpack myIniFile')
where
myIniFile' = case myIniFile of
Nothing -> panic "For Prod mode, you need to fill a gargantext.ini file"
Nothing -> panic "[ERROR] gargantext.ini needed"
Just i -> i
Mock -> startGargantextMock myPort'
_ -> startGargantextMock myPort'
putStrLn $ "Starting Gargantext with mode: " <> show myMode
putStrLn $ "Starting with " <> show myMode <> " mode."
start
-- main' :: IO ()
--main' = putStrLn $ show $ M.conditional $ M.myMat 10
package.yaml
View file @ 7da5cfa2
......@@ -28,6 +28,7 @@ library:
- Gargantext.API.Auth
- Gargantext.API.Count
- Gargantext.API.FrontEnd
- Gargantext.API.Ngrams
- Gargantext.API.Node
- Gargantext.API.Orchestrator
- Gargantext.API.Search
......@@ -50,6 +51,7 @@ library:
- Gargantext.Text.Examples
- Gargantext.Text.List.CSV
- Gargantext.Text.Metrics
- Gargantext.Text.Metrics.TFICF
- Gargantext.Text.Metrics.CharByChar
- Gargantext.Text.Metrics.Count
- Gargantext.Text.Parsers
......@@ -109,6 +111,7 @@ library:
- ini
- insert-ordered-containers
- jose-jwt
- json-state
# - kmeans-vector
- KMP
- lens
......@@ -159,11 +162,13 @@ library:
- text-metrics
- time
- time-locale-compat
- time-units
- timezone-series
- transformers
- transformers-base
- unordered-containers
- uuid
- validity
- vector
- wai
- wai-cors
......
src/Gargantext/API.hs
View file @ 7da5cfa2
......@@ -44,6 +44,7 @@ import GHC.Generics (D1, Meta (..), Rep)
import GHC.TypeLits (AppendSymbol, Symbol)
import Control.Lens
import Control.Exception (finally)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (runReaderT)
import Data.Aeson.Encode.Pretty (encodePretty)
......@@ -72,6 +73,7 @@ import Gargantext.Prelude
import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer)
import Gargantext.API.Auth (AuthRequest, AuthResponse, auth)
import Gargantext.API.Ngrams (HasRepoVar(..), HasRepoSaver(..), saveRepo)
import Gargantext.API.Node ( GargServer
, Roots , roots
, NodeAPI , nodeAPI
......@@ -83,6 +85,7 @@ import Gargantext.API.Node ( GargServer
, HyperdataAnnuaire
)
--import Gargantext.Database.Node.Contact (HyperdataContact)
import Gargantext.Database.Utils (HasConnection)
import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId)
import Gargantext.API.Count ( CountAPI, count, Query)
import Gargantext.API.Search ( SearchAPI, search, SearchQuery)
......@@ -163,9 +166,8 @@ makeMockApp env = do
makeDevApp :: Env -> IO Application
makeDevApp env = do
serverApp <- makeApp env
makeDevMiddleware :: IO Middleware
makeDevMiddleware = do
-- logWare <- mkRequestLogger def { destination = RequestLogger.Logger $ env^.logger }
--logWare <- mkRequestLogger def { destination = RequestLogger.Logger "/tmp/logs.txt" }
......@@ -192,8 +194,8 @@ makeDevApp env = do
--let warpS = Warp.setPort (8008 :: Int) -- (env^.settings.appPort)
-- $ Warp.defaultSettings
--pure (warpS, logWare $ checkOriginAndHost $ corsMiddleware $ serverApp)
pure $ logStdoutDev $ corsMiddleware $ serverApp
--pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
pure $ logStdoutDev . corsMiddleware
---------------------------------------------------------------------
-- | API Global
......@@ -276,12 +278,13 @@ type API = SwaggerFrontAPI :<|> GargAPI :<|> Get '[HTML] Html
---------------------------------------------------------------------
-- | Server declarations
server :: Env -> IO (Server API)
server :: (HasConnection env, HasRepoVar env, HasRepoSaver env)
=> env -> IO (Server API)
server env = do
-- orchestrator <- scrapyOrchestrator env
pure $ swaggerFront
:<|> hoistServer (Proxy :: Proxy GargAPI) (`runReaderT` env) serverGargAPI
:<|> serverIndex
:<|> serverStatic
serverGargAPI :: GargServer GargAPI
serverGargAPI -- orchestrator
......@@ -299,9 +302,12 @@ serverGargAPI -- orchestrator
where
fakeUserId = 1 -- TODO
serverIndex :: Server (Get '[HTML] Html)
serverIndex = $(do (Just s) <- liftIO (fileTypeToFileTree (FileTypeFile "purescript-gargantext/dist/index.html"))
fileTreeToServer s)
serverStatic :: Server (Get '[HTML] Html)
serverStatic = $(do
let path = "purescript-gargantext/dist/index.html"
Just s <- liftIO (fileTypeToFileTree (FileTypeFile path))
fileTreeToServer s
)
---------------------------------------------------------------------
swaggerFront :: Server SwaggerFrontAPI
......@@ -312,11 +318,12 @@ gargMock :: Server GargAPI
gargMock = mock apiGarg Proxy
---------------------------------------------------------------------
makeApp :: Env -> IO Application
makeApp :: (HasConnection env, HasRepoVar env, HasRepoSaver env)
=> env -> IO Application
makeApp = fmap (serve api) . server
appMock :: Application
appMock = serve api (swaggerFront :<|> gargMock :<|> serverIndex)
appMock = serve api (swaggerFront :<|> gargMock :<|> serverStatic)
---------------------------------------------------------------------
api :: Proxy API
......@@ -367,13 +374,19 @@ portRouteInfo port = do
T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/index.html"
T.putStrLn $ "http://localhost:" <> toUrlPiece port <> "/swagger-ui"
stopGargantext :: HasRepoSaver env => env -> IO ()
stopGargantext env = do
T.putStrLn "----- Stopping gargantext -----"
runReaderT saveRepo env
-- | startGargantext takes as parameters port number and Ini file.
startGargantext :: PortNumber -> FilePath -> IO ()
startGargantext port file = do
env <- newEnv port file
portRouteInfo port
app <- makeDevApp env
run port app
app <- makeApp env
mid <- makeDevMiddleware
run port (mid app) `finally` stopGargantext env
startGargantextMock :: PortNumber -> IO ()
startGargantextMock port = do
......
src/Gargantext/API/Ngrams.hs
View file @ 7da5cfa2
......@@ -15,6 +15,7 @@ add get
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude #-}
......@@ -22,49 +23,64 @@ add get
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS -fno-warn-orphans #-}
module Gargantext.API.Ngrams
where
import Prelude (round)
import Debug.Trace (trace)
import Prelude (Enum, Bounded, Semigroup(..), minBound, maxBound {-, round-}, error)
-- import Gargantext.Database.Schema.User (UserId)
import Data.Functor (($>))
import Data.Patch.Class (Replace, replace, new)
--import qualified Data.Map.Strict.Patch as PM
import Data.Patch.Class (Replace, replace, Action(act), Applicable(..),
Composable(..), Transformable(..),
PairPatch(..), Patched, ConflictResolution,
ConflictResolutionReplace, ours)
import qualified Data.Map.Strict.Patch as PM
import Data.Monoid
--import Data.Semigroup
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Maybe (isJust)
import Data.Tuple.Extra (first)
-- import qualified Data.Map.Strict as DM
import Data.Map.Strict (Map, mapKeys, fromListWith)
-- import qualified Data.List as List
import Data.Maybe (catMaybes)
-- import Data.Tuple.Extra (first)
import qualified Data.Map.Strict as Map
import Data.Map.Strict (Map)
--import qualified Data.Set as Set
import Control.Lens (makeLenses, Prism', prism', (^..), (.~), (#), to, withIndex, folded, ifolded)
import Control.Category ((>>>))
import Control.Concurrent
import Control.Lens (makeLenses, makePrisms, Getter, Prism', prism', Iso', iso, from, (^..), (.~), (#), to, {-withIndex, folded, ifolded,-} view, (^.), (+~), (%~), at, _Just, Each(..), itraverse_, (.=), both, mapped)
import Control.Monad (guard)
import Control.Monad.Error.Class (MonadError, throwError)
import Data.Aeson
import Control.Monad.Reader
import Control.Monad.State
import Data.Aeson hiding ((.=))
import Data.Aeson.TH (deriveJSON)
import Data.Either(Either(Left))
import Data.Map (lookup)
-- import Data.Map (lookup)
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import Data.Swagger hiding (version, patch)
import Data.Text (Text)
import Data.Validity
import GHC.Generics (Generic)
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Types.Node (NodeType(..))
import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
import Gargantext.Database.Schema.Ngrams (NgramsType, NgramsTypeId, ngramsTypeId, NgramsTableData(..))
-- import Gargantext.Database.Schema.Ngrams (NgramsTypeId, ngramsTypeId, NgramsTableData(..))
import Gargantext.Database.Config (userMaster)
import Gargantext.Database.Schema.Ngrams (NgramsType)
import Gargantext.Database.Utils (fromField', HasConnection)
import Gargantext.Database.Lists (listsWith)
import Gargantext.Database.Schema.Node (HasNodeError)
import Database.PostgreSQL.Simple.FromField (FromField, fromField)
import qualified Gargantext.Database.Schema.Ngrams as Ngrams
import Gargantext.Database.Schema.NodeNgram
import Gargantext.Database.Utils (Cmd)
-- import Gargantext.Database.Schema.NodeNgram hiding (Action)
import Gargantext.Prelude
import Gargantext.Core.Types (ListType(..), ListTypeId, ListId, CorpusId, Limit, Offset, listTypeId)
import Prelude (Enum, Bounded, minBound, maxBound)
-- import Gargantext.Core.Types (ListTypeId, listTypeId)
import Gargantext.Core.Types (ListType(..), NodeId, ListId, CorpusId, Limit, Offset)
import Servant hiding (Patch)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
......@@ -96,6 +112,25 @@ instance Arbitrary TabType
where
arbitrary = elements [minBound .. maxBound]
newtype MSet a = MSet (Map a ())
deriving (Eq, Ord, Show, Generic, Arbitrary, Semigroup, Monoid)
instance ToJSON a => ToJSON (MSet a) where
toJSON (MSet m) = toJSON (Map.keys m)
toEncoding (MSet m) = toEncoding (Map.keys m)
mSetFromSet :: Set a -> MSet a
mSetFromSet = MSet . Map.fromSet (const ())
mSetFromList :: Ord a => [a] -> MSet a
mSetFromList = MSet . Map.fromList . map (\x -> (x, ()))
instance (Ord a, FromJSON a) => FromJSON (MSet a) where
parseJSON = fmap mSetFromList . parseJSON
instance (ToJSONKey a, ToSchema a) => ToSchema (MSet a) where
-- TODO
------------------------------------------------------------------------
type NgramsTerm = Text
......@@ -104,7 +139,7 @@ data NgramsElement =
, _ne_list :: ListType
, _ne_occurrences :: Int
, _ne_parent :: Maybe NgramsTerm
, _ne_children :: Set NgramsTerm
, _ne_children :: MSet NgramsTerm
}
deriving (Ord, Eq, Show, Generic)
......@@ -116,10 +151,21 @@ instance Arbitrary NgramsElement where
arbitrary = elements [NgramsElement "sport" GraphList 1 Nothing mempty]
------------------------------------------------------------------------
newtype NgramsTable = NgramsTable { _ngramsTable :: [NgramsElement] }
newtype NgramsTable = NgramsTable [NgramsElement]
deriving (Ord, Eq, Generic, ToJSON, FromJSON, Show)
type ListNgrams = NgramsTable
makePrisms ''NgramsTable
-- | Question: why these repetition of Type in this instance
-- may you document it please ?
instance Each NgramsTable NgramsTable NgramsElement NgramsElement where
each = _NgramsTable . each
-- TODO discuss
-- | TODO Check N and Weight
{-
toNgramsElement :: [NgramsTableData] -> [NgramsElement]
toNgramsElement ns = map toNgramsElement' ns
where
......@@ -132,35 +178,40 @@ toNgramsElement ns = map toNgramsElement' ns
lt' = maybe (panic "API.Ngrams: listypeId") identity lt
mapParent :: Map Int Text
mapParent = fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
mapParent = Map.fromListWith (<>) $ map (\(NgramsTableData i _ t _ _ _) -> (i,t)) ns
mapChildren :: Map Text (Set Text)
mapChildren = mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
$ fromListWith (<>)
mapChildren = Map.mapKeys (\i -> (maybe (panic "API.Ngrams.mapChildren: ParentId with no Terms: Impossible") identity $ lookup i mapParent))
$ Map.fromListWith (<>)
$ map (first fromJust)
$ filter (isJust . fst)
$ map (\(NgramsTableData _ p t _ _ _) -> (p, Set.singleton t)) ns
-}
instance Arbitrary NgramsTable where
arbitrary = elements
[ NgramsTable
[ NgramsElement "animal" GraphList 1 Nothing (Set.fromList ["dog", "cat"])
mockTable :: NgramsTable
mockTable = NgramsTable
[ NgramsElement "animal" GraphList 1 Nothing (mSetFromList ["dog", "cat"])
, NgramsElement "cat" GraphList 1 (Just "animal") mempty
, NgramsElement "cats" StopList 4 Nothing mempty
, NgramsElement "dog" GraphList 3 (Just "animal")(Set.fromList ["dogs"])
, NgramsElement "dog" GraphList 3 (Just "animal")(mSetFromList ["dogs"])
, NgramsElement "dogs" StopList 4 (Just "dog") mempty
, NgramsElement "fox" GraphList 1 Nothing mempty
, NgramsElement "object" CandidateList 2 Nothing mempty
, NgramsElement "nothing" StopList 4 Nothing mempty
, NgramsElement "organic" GraphList 3 Nothing (Set.singleton "flower")
, NgramsElement "organic" GraphList 3 Nothing (mSetFromList ["flower"])
, NgramsElement "flower" GraphList 3 (Just "organic") mempty
, NgramsElement "moon" CandidateList 1 Nothing mempty
, NgramsElement "sky" StopList 1 Nothing mempty
]
]
instance Arbitrary NgramsTable where
arbitrary = pure mockTable
instance ToSchema NgramsTable
------------------------------------------------------------------------
type NgramsTableMap = Map NgramsTerm NgramsElement
------------------------------------------------------------------------
-- On the Client side:
--data Action = InGroup NgramsId NgramsId
......@@ -173,8 +224,8 @@ data PatchSet a = PatchSet
}
deriving (Eq, Ord, Show, Generic)
instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
arbitrary = PatchSet <$> arbitrary <*> arbitrary
makeLenses ''PatchSet
makePrisms ''PatchSet
instance ToJSON a => ToJSON (PatchSet a) where
toJSON = genericToJSON $ unPrefix "_"
......@@ -183,7 +234,106 @@ instance ToJSON a => ToJSON (PatchSet a) where
instance (Ord a, FromJSON a) => FromJSON (PatchSet a) where
parseJSON = genericParseJSON $ unPrefix "_"
{-
instance (Ord a, Arbitrary a) => Arbitrary (PatchSet a) where
arbitrary = PatchSet <$> arbitrary <*> arbitrary
type instance Patched (PatchSet a) = Set a
type ConflictResolutionPatchSet a = SimpleConflictResolution' (Set a)
type instance ConflictResolution (PatchSet a) = ConflictResolutionPatchSet a
instance Ord a => Semigroup (PatchSet a) where
p <> q = PatchSet { _rem = (q ^. rem) `Set.difference` (p ^. add) <> p ^. rem
, _add = (q ^. add) `Set.difference` (p ^. rem) <> p ^. add
} -- TODO Review
instance Ord a => Monoid (PatchSet a) where
mempty = PatchSet mempty mempty
instance Ord a => Group (PatchSet a) where
invert (PatchSet r a) = PatchSet a r
instance Ord a => Composable (PatchSet a) where
composable _ _ = undefined
instance Ord a => Action (PatchSet a) (Set a) where
act p source = (source `Set.difference` (p ^. rem)) <> p ^. add
instance Applicable (PatchSet a) (Set a) where
applicable _ _ = mempty
instance Ord a => Validity (PatchSet a) where
validate p = check (Set.disjoint (p ^. rem) (p ^. add)) "_rem and _add should be dijoint"
instance Ord a => Transformable (PatchSet a) where
transformable = undefined
conflicts _p _q = undefined
transformWith conflict p q = undefined conflict p q
instance ToSchema a => ToSchema (PatchSet a)
-}
type AddRem = Replace (Maybe ())
remPatch, addPatch :: AddRem
remPatch = replace (Just ()) Nothing
addPatch = replace Nothing (Just ())
isRem :: Replace (Maybe ()) -> Bool
isRem = (== remPatch)
type PatchMap = PM.PatchMap
newtype PatchMSet a = PatchMSet (PatchMap a AddRem)
deriving (Eq, Show, Generic, Validity, Semigroup, Monoid,
Transformable, Composable)
type ConflictResolutionPatchMSet a = a -> ConflictResolutionReplace (Maybe ())
type instance ConflictResolution (PatchMSet a) = ConflictResolutionPatchMSet a
-- TODO this breaks module abstraction
makePrisms ''PM.PatchMap
makePrisms ''PatchMSet
_PatchMSetIso :: Ord a => Iso' (PatchMSet a) (PatchSet a)
_PatchMSetIso = _PatchMSet . _PatchMap . iso f g . from _PatchSet
where
f :: Ord a => Map a (Replace (Maybe ())) -> (Set a, Set a)
f = Map.partition isRem >>> both %~ Map.keysSet
g :: Ord a => (Set a, Set a) -> Map a (Replace (Maybe ()))
g (rems, adds) = Map.fromSet (const remPatch) rems
<> Map.fromSet (const addPatch) adds
instance Ord a => Action (PatchMSet a) (MSet a) where
act (PatchMSet p) (MSet m) = MSet $ act p m
instance Ord a => Applicable (PatchMSet a) (MSet a) where
applicable (PatchMSet p) (MSet m) = applicable p m
instance (Ord a, ToJSON a) => ToJSON (PatchMSet a) where
toJSON = toJSON . view _PatchMSetIso
toEncoding = toEncoding . view _PatchMSetIso
instance (Ord a, FromJSON a) => FromJSON (PatchMSet a) where
parseJSON = fmap (_PatchMSetIso #) . parseJSON
instance (Ord a, Arbitrary a) => Arbitrary (PatchMSet a) where
arbitrary = (PatchMSet . PM.fromMap) <$> arbitrary
instance ToSchema a => ToSchema (PatchMSet a) where
-- TODO
declareNamedSchema _ = undefined
type instance Patched (PatchMSet a) = MSet a
instance (Eq a, Arbitrary a) => Arbitrary (Replace a) where
arbitrary = uncurry replace <$> arbitrary
-- If they happen to be equal then the patch is Keep.
instance ToSchema a => ToSchema (Replace a) where
declareNamedSchema (_ :: proxy (Replace a)) = do
......@@ -199,29 +349,123 @@ instance ToSchema a => ToSchema (Replace a) where
& required .~ [ "old", "new" ]
data NgramsPatch =
NgramsPatch { _patch_children :: PatchSet NgramsTerm
NgramsPatch { _patch_children :: PatchMSet NgramsTerm
, _patch_list :: Replace ListType -- TODO Map UserId ListType
}
deriving (Ord, Eq, Show, Generic)
deriving (Eq, Show, Generic)
deriveJSON (unPrefix "_") ''NgramsPatch
makeLenses ''NgramsPatch
-- instance Semigroup NgramsPatch where
instance ToSchema NgramsPatch
instance Arbitrary NgramsPatch where
arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
newtype NgramsTablePatch =
NgramsTablePatch { _ntp_ngrams_patches :: Map NgramsTerm NgramsPatch }
deriving (Ord, Eq, Show, Generic, Arbitrary, ToJSON, FromJSON)
makeLenses ''NgramsTablePatch
type NgramsPatchIso = PairPatch (PatchMSet NgramsTerm) (Replace ListType)
_NgramsPatch :: Iso' NgramsPatch NgramsPatchIso
_NgramsPatch = iso (\(NgramsPatch c l) -> c :*: l) (\(c :*: l) -> NgramsPatch c l)
instance Semigroup NgramsPatch where
p <> q = _NgramsPatch # (p ^. _NgramsPatch <> q ^. _NgramsPatch)
instance Monoid NgramsPatch where
mempty = _NgramsPatch # mempty
instance Validity NgramsPatch where
validate p = p ^. _NgramsPatch . to validate
instance Transformable NgramsPatch where
transformable p q = transformable (p ^. _NgramsPatch) (q ^. _NgramsPatch)
conflicts p q = conflicts (p ^. _NgramsPatch) (q ^. _NgramsPatch)
transformWith conflict p q = (_NgramsPatch # p', _NgramsPatch # q')
where
(p', q') = transformWith conflict (p ^. _NgramsPatch) (q ^. _NgramsPatch)
type ConflictResolutionNgramsPatch =
( ConflictResolutionPatchMSet NgramsTerm
, ConflictResolutionReplace ListType
)
type instance ConflictResolution NgramsPatch =
ConflictResolutionNgramsPatch
type PatchedNgramsPatch = (Set NgramsTerm, ListType)
-- ~ Patched NgramsPatchIso
type instance Patched NgramsPatch = PatchedNgramsPatch
instance Applicable NgramsPatch (Maybe NgramsElement) where
applicable p Nothing = check (p == mempty) "NgramsPatch should be empty here"
applicable p (Just ne) =
-- TODO how to patch _ne_parent ?
applicable (p ^. patch_children) (ne ^. ne_children) <>
applicable (p ^. patch_list) (ne ^. ne_list)
instance Action NgramsPatch NgramsElement where
act p = (ne_children %~ act (p ^. patch_children))
. (ne_list %~ act (p ^. patch_list))
instance Action NgramsPatch (Maybe NgramsElement) where
act = fmap . act
newtype NgramsTablePatch = NgramsTablePatch (PatchMap NgramsTerm NgramsPatch)
deriving (Eq, Show, Generic, ToJSON, FromJSON, Semigroup, Monoid, Validity, Transformable)
instance FromField NgramsTablePatch
where
fromField = fromField'
instance FromField (PatchMap NgramsType (PatchMap NodeId NgramsTablePatch))
where
fromField = fromField'
--instance (Ord k, Action pv (Maybe v)) => Action (PatchMap k pv) (Map k v) where
--
type instance ConflictResolution NgramsTablePatch =
NgramsTerm -> ConflictResolutionNgramsPatch
type PatchedNgramsTablePatch = Map NgramsTerm PatchedNgramsPatch
-- ~ Patched (PatchMap NgramsTerm NgramsPatch)
type instance Patched NgramsTablePatch = PatchedNgramsTablePatch
makePrisms ''NgramsTablePatch
instance ToSchema (PatchMap NgramsTerm NgramsPatch)
instance ToSchema NgramsTablePatch
-- TODO: replace by mempty once we have the Monoid instance
emptyNgramsTablePatch :: NgramsTablePatch
emptyNgramsTablePatch = NgramsTablePatch mempty
instance Applicable NgramsTablePatch (Maybe NgramsTableMap) where
applicable p = applicable (p ^. _NgramsTablePatch)
instance Action NgramsTablePatch (Maybe NgramsTableMap) where
act p =
fmap (execState (reParentNgramsTablePatch p)) .
act (p ^. _NgramsTablePatch)
instance Arbitrary NgramsTablePatch where
arbitrary = NgramsTablePatch <$> PM.fromMap <$> arbitrary
-- Should it be less than an Lens' to preserve PatchMap's abstraction.
-- ntp_ngrams_patches :: Lens' NgramsTablePatch (Map NgramsTerm NgramsPatch)
-- ntp_ngrams_patches = _NgramsTablePatch . undefined
type ReParent a = forall m. MonadState NgramsTableMap m => a -> m ()
reParent :: Maybe NgramsTerm -> ReParent NgramsTerm
reParent parent child = at child . _Just . ne_parent .= parent
reParentAddRem :: NgramsTerm -> NgramsTerm -> ReParent AddRem
reParentAddRem parent child p =
reParent (if isRem p then Nothing else Just parent) child
reParentNgramsPatch :: NgramsTerm -> ReParent NgramsPatch
reParentNgramsPatch parent ngramsPatch =
itraverse_ (reParentAddRem parent) (ngramsPatch ^. patch_children . _PatchMSet . _PatchMap)
-- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
reParentNgramsTablePatch :: ReParent NgramsTablePatch
reParentNgramsTablePatch p = itraverse_ reParentNgramsPatch (p ^. _NgramsTablePatch. _PatchMap)
-- TODO FoldableWithIndex/TraversableWithIndex for PatchMap
------------------------------------------------------------------------
------------------------------------------------------------------------
......@@ -231,7 +475,7 @@ data Versioned a = Versioned
{ _v_version :: Version
, _v_data :: a
}
deriving (Generic)
deriving (Generic, Show)
deriveJSON (unPrefix "_v_") ''Versioned
makeLenses ''Versioned
instance ToSchema a => ToSchema (Versioned a)
......@@ -262,14 +506,14 @@ ngramsIdPatch = fromList $ catMaybes $ reverse [ replace (1::NgramsId) (Just $ n
type TableNgramsApiGet = Summary " Table Ngrams API Get"
:> QueryParam "ngramsType" TabType
:> QueryParam "list" ListId
:> QueryParams "list" ListId
:> QueryParam "limit" Limit
:> QueryParam "offset" Offset
:> Get '[JSON] (Versioned NgramsTable)
type TableNgramsApi = Summary " Table Ngrams API Change"
:> QueryParam "ngramsType" TabType
:> QueryParam "list" ListId
:> QueryParam' '[Required, Strict] "list" ListId
:> ReqBody '[JSON] (Versioned NgramsTablePatch)
:> Put '[JSON] (Versioned NgramsTablePatch)
......@@ -289,6 +533,7 @@ instance HasNgramError ServantErr where
ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
ngramError nne = throwError $ _NgramError # nne
{-
-- TODO: Replace.old is ignored which means that if the current list
-- `GraphList` and that the patch is `Replace CandidateList StopList` then
-- the list is going to be `StopList` while it should keep `GraphList`.
......@@ -309,6 +554,7 @@ mkChildrenGroups addOrRem nt patches =
| (parent, patch) <- patches ^.. ntp_ngrams_patches . ifolded . withIndex
, child <- patch ^.. patch_children . to addOrRem . folded
]
-}
ngramsTypeFromTabType :: Maybe TabType -> NgramsType
ngramsTypeFromTabType maybeTabType =
......@@ -322,46 +568,201 @@ ngramsTypeFromTabType maybeTabType =
Terms -> Ngrams.NgramsTerms
_ -> panic $ lieu <> "No Ngrams for this tab"
------------------------------------------------------------------------
data Repo s p = Repo
{ _r_version :: Version
, _r_state :: s
, _r_history :: [p]
-- ^ first patch in the list is the most recent
}
deriving (Generic)
instance (FromJSON s, FromJSON p) => FromJSON (Repo s p) where
parseJSON = genericParseJSON $ unPrefix "_r_"
instance (ToJSON s, ToJSON p) => ToJSON (Repo s p) where
toJSON = genericToJSON $ unPrefix "_r_"
toEncoding = genericToEncoding $ unPrefix "_r_"
makeLenses ''Repo
initRepo :: Monoid s => Repo s p
initRepo = Repo 1 mempty []
type NgramsRepo = Repo NgramsState NgramsStatePatch
type NgramsState = Map NgramsType (Map NodeId NgramsTableMap)
type NgramsStatePatch = PatchMap NgramsType (PatchMap NodeId NgramsTablePatch)
initMockRepo :: NgramsRepo
initMockRepo = Repo 1 s []
where
s = Map.singleton Ngrams.NgramsTerms
$ Map.singleton 47254
$ Map.fromList
[ (n ^. ne_ngrams, n) | n <- mockTable ^. _NgramsTable ]
class HasRepoVar env where
repoVar :: Getter env (MVar NgramsRepo)
instance HasRepoVar (MVar NgramsRepo) where
repoVar = identity
class HasRepoSaver env where
repoSaver :: Getter env (IO ())
instance HasRepoSaver (IO ()) where
repoSaver = identity
type RepoCmdM env err m =
( MonadReader env m
, MonadError err m
, MonadIO m
, HasRepoVar env
, HasRepoSaver env
)
------------------------------------------------------------------------
saveRepo :: ( MonadReader env m, MonadIO m, HasRepoSaver env )
=> m ()
saveRepo = liftIO =<< view repoSaver
listTypeConflictResolution :: ListType -> ListType -> ListType
listTypeConflictResolution _ _ = undefined -- TODO Use Map User ListType
ngramsStatePatchConflictResolution
:: NgramsType -> NodeId -> NgramsTerm
-> ConflictResolutionNgramsPatch
ngramsStatePatchConflictResolution _ngramsType _nodeId _ngramsTerm
= (const ours, ours)
-- undefined {- TODO think this through -}, listTypeConflictResolution)
class HasInvalidError e where
_InvalidError :: Prism' e Validation
instance HasInvalidError ServantErr where
_InvalidError = panic "error" {-prism' make match
where
err = err500 { errBody = "InvalidError" }
make _ = err
match e = guard (e == err) $> UnsupportedVersion-}
assertValid :: (MonadError e m, HasInvalidError e) => Validation -> m ()
assertValid v = when (not $ validationIsValid v) $ throwError $ _InvalidError # v
-- Current state:
-- Insertions are not considered as patches,
-- they do not extend history,
-- they do not bump version.
insertNewOnly :: a -> Maybe a -> Maybe a
insertNewOnly a = maybe (Just a) (const $ error "insertNewOnly: impossible")
-- TODO error handling
something :: Monoid a => Maybe a -> a
something Nothing = mempty
something (Just a) = a
putListNgrams :: RepoCmdM env err m
=> NodeId -> NgramsType
-> [NgramsElement] -> m ()
putListNgrams listId ngramsType nes = do
var <- view repoVar
liftIO $ modifyMVar_ var $
pure . (r_state . at ngramsType %~ (Just . (at listId %~ insertNewOnly m) . something))
saveRepo
where
m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes
-- Apply the given patch to the DB and returns the patch to be applied on the
-- cilent.
-- client.
-- TODO:
-- In this perliminary version the OT aspect is missing, therefore the version
-- number is always 1 and the returned patch is always empty.
tableNgramsPatch :: (HasNgramError err, HasNodeError err)
=> CorpusId -> Maybe TabType -> Maybe ListId
tableNgramsPatch :: (HasNgramError err, HasInvalidError err,
RepoCmdM env err m)
=> CorpusId -> Maybe TabType -> ListId
-> Versioned NgramsTablePatch
-> Cmd err (Versioned NgramsTablePatch)
tableNgramsPatch corpusId maybeTabType maybeList (Versioned version patch) = do
when (version /= 1) $ ngramError UnsupportedVersion
-> m (Versioned NgramsTablePatch)
tableNgramsPatch _corpusId maybeTabType listId (Versioned p_version p_table) = do
let ngramsType = ngramsTypeFromTabType maybeTabType
listId <- maybe (defaultList corpusId) pure maybeList
(p0, p0_validity) = PM.singleton listId p_table
(p, p_validity) = PM.singleton ngramsType p0
assertValid p0_validity
assertValid p_validity
var <- view repoVar
(p'_applicable, vq') <- liftIO $ modifyMVar var $ \r ->
let
q = mconcat $ take (r ^. r_version - p_version) (r ^. r_history)
(p', q') = transformWith ngramsStatePatchConflictResolution p q
r' = r & r_version +~ 1
& r_state %~ act p'
& r_history %~ (p' :)
q'_table = q' ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
p'_applicable = applicable p' (r ^. r_state)
in
pure (r', (p'_applicable, Versioned (r' ^. r_version) q'_table))
saveRepo
assertValid p'_applicable
pure vq'
{- DB version
when (version /= 1) $ ngramError UnsupportedVersion
updateNodeNgrams $ NodeNgramsUpdate
{ _nnu_user_list_id = listId
, _nnu_lists_update = mkListsUpdate ngramsType patch
, _nnu_rem_children = mkChildrenGroups _rem ngramsType patch
, _nnu_add_children = mkChildrenGroups _add ngramsType patch
}
pure $ Versioned 1 emptyNgramsTablePatch
pure $ Versioned 1 mempty
-}
mergeNgramsElement :: NgramsElement -> NgramsElement -> NgramsElement
mergeNgramsElement _neOld neNew = neNew
{-
{ _ne_list :: ListType
If we merge the parents/children we can potentially create cycles!
, _ne_parent :: Maybe NgramsTerm
, _ne_children :: MSet NgramsTerm
}
-}
getListNgrams :: RepoCmdM env err m
=> [NodeId] -> NgramsType -> m (Versioned ListNgrams)
getListNgrams nodeIds ngramsType = do
v <- view repoVar
repo <- liftIO $ readMVar v
let
ngramsMap = repo ^. r_state . at ngramsType . _Just
ngrams =
Map.unionsWith mergeNgramsElement
[ ngramsMap ^. at nodeId . _Just | nodeId <- nodeIds ]
pure $ Versioned (repo ^. r_version) (NgramsTable (ngrams ^.. each))
-- | TODO Errors management
-- TODO: polymorphic for Annuaire or Corpus or ...
getTableNgrams :: HasNodeError err
-- | Table of Ngrams is a ListNgrams formatted (sorted and/or cut).
getTableNgrams :: (RepoCmdM env err m, HasNodeError err, HasConnection env)
=> CorpusId -> Maybe TabType
-> Maybe ListId -> Maybe Limit -> Maybe Offset
-> Cmd err (Versioned NgramsTable)
getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
-> [ListId] -> Maybe Limit -> Maybe Offset
-- -> Maybe MinSize -> Maybe MaxSize
-- -> Maybe ListType
-- -> Maybe Text -- full text search
-> m (Versioned NgramsTable)
getTableNgrams _cId maybeTabType listIds mlimit moffset = do
let ngramsType = ngramsTypeFromTabType maybeTabType
listId <- maybe (defaultList cId) pure maybeListId
let
defaultLimit = 10 -- TODO
limit_ = maybe defaultLimit identity mlimit
offset_ = maybe 0 identity moffset
ngramsTableDatas <-
Ngrams.getNgramsTableDb NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
-- printDebug "ngramsTableDatas" ngramsTableDatas
lists <- catMaybes <$> listsWith userMaster
trace (show lists) $ getListNgrams (lists <> listIds) ngramsType
& mapped . v_data . _NgramsTable %~ (take limit_ . drop offset_)
pure $ Versioned 1 $ NgramsTable (toNgramsElement ngramsTableDatas)
src/Gargantext/API/Node.hs
View file @ 7da5cfa2
......@@ -46,7 +46,7 @@ import Data.Time (UTCTime)
import GHC.Generics (Generic)
import Servant
import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams)
import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams, HasRepoVar, HasRepoSaver)
import Gargantext.Prelude
import Gargantext.Database.Types.Node
import Gargantext.Database.Utils -- (Cmd, CmdM)
......@@ -72,7 +72,10 @@ import Gargantext.Database.Types.Node (CorpusId, ContactId)
import Test.QuickCheck (elements)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
type GargServer api = forall env m. CmdM env ServantErr m => ServerT api m
type GargServer api =
forall env m.
(CmdM env ServantErr m, HasRepoVar env, HasRepoSaver env)
=> ServerT api m
-------------------------------------------------------------------
-- TODO-ACCESS: access by admin only.
......@@ -279,7 +282,7 @@ graphAPI nId = do
nodeGraph <- getNode nId HyperdataGraph
let title = "Graph Title"
let title = "Title"
let metadata = GraphMetadata title [maybe 0 identity $ _node_parentId nodeGraph]
[ LegendField 1 "#FFF" "Cluster"
, LegendField 2 "#FFF" "Cluster"
......
src/Gargantext/API/Settings.hs
View file @ 7da5cfa2
......@@ -17,25 +17,31 @@ Portability : POSIX
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.API.Settings
where
import System.Directory
import System.Log.FastLogger
import GHC.Enum
import GHC.Generics (Generic)
import Prelude (Bounded())
import Prelude (Bounded(), fail)
import System.Environment (lookupEnv)
import System.IO (FilePath)
import Database.PostgreSQL.Simple (Connection, connect)
import Network.HTTP.Client (Manager)
import Network.HTTP.Client.TLS (newTlsManager)
import Data.Aeson
import Data.Maybe (fromMaybe)
import Data.Either (either)
import Data.JsonState (mkSaveState)
import Data.Text
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Units
import Data.ByteString.Lazy.Internal
import Servant
......@@ -45,10 +51,14 @@ import Web.HttpApiData (parseUrlPiece)
import qualified Jose.Jwk as Jose
import qualified Jose.Jwa as Jose
import Control.Concurrent
import Control.Exception (finally)
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Lens
import Gargantext.Prelude
import Gargantext.Database.Utils (databaseParameters, HasConnection(..))
import Gargantext.Database.Utils (databaseParameters, HasConnection(..), Cmd', runCmd)
import Gargantext.API.Ngrams (NgramsRepo, HasRepoVar(..), HasRepoSaver(..), initMockRepo, r_version, saveRepo)
import Gargantext.API.Orchestrator.Types
type PortNumber = Int
......@@ -128,6 +138,8 @@ data Env = Env
{ _env_settings :: !Settings
, _env_logger :: !LoggerSet
, _env_conn :: !Connection
, _env_repo_var :: !(MVar NgramsRepo)
, _env_repo_saver :: !(IO ())
, _env_manager :: !Manager
, _env_self_url :: !BaseUrl
, _env_scrapers :: !ScrapersEnv
......@@ -139,6 +151,12 @@ makeLenses ''Env
instance HasConnection Env where
connection = env_conn
instance HasRepoVar Env where
repoVar = env_repo_var
instance HasRepoSaver Env where
repoSaver = env_repo_saver
data MockEnv = MockEnv
{ _menv_firewall :: !FireWall
}
......@@ -146,22 +164,109 @@ data MockEnv = MockEnv
makeLenses ''MockEnv
repoSnapshot :: FilePath
repoSnapshot = "repo.json"
readRepo :: IO (MVar NgramsRepo)
readRepo = do
-- | Does file exist ? :: Bool
repoFile <- doesFileExist repoSnapshot
-- | Is file not empty ? :: Bool
repoExists <- if repoFile
then (>0) <$> getFileSize repoSnapshot
else pure repoFile
newMVar =<<
if repoExists
then do
e_repo <- eitherDecodeFileStrict repoSnapshot
repo <- either fail pure e_repo
let archive = repoSnapshot <> ".v" <> show (repo ^. r_version)
copyFile repoSnapshot archive
pure repo
else
pure initMockRepo
mkRepoSaver :: MVar NgramsRepo -> IO (IO ())
mkRepoSaver repo_var = do
saveAction <- mkSaveState (10 :: Second) repoSnapshot
pure $ readMVar repo_var >>= saveAction
newEnv :: PortNumber -> FilePath -> IO Env
newEnv port file = do
manager <- newTlsManager
settings <- pure (devSettings & appPort .~ port) -- TODO read from 'file'
when (port /= settings ^. appPort) $
panic "TODO: conflicting settings of port"
self_url <- parseBaseUrl $ "http://0.0.0.0:" <> show port
param <- databaseParameters file
conn <- connect param
repo_var <- readRepo
repo_saver <- mkRepoSaver repo_var
scrapers_env <- newJobEnv defaultSettings manager
logger <- newStderrLoggerSet defaultBufSize
pure $ Env
{ _env_settings = settings
, _env_logger = logger
, _env_conn = conn
, _env_repo_var = repo_var
, _env_repo_saver = repo_saver
, _env_manager = manager
, _env_scrapers = scrapers_env
, _env_self_url = self_url
}
data DevEnv = DevEnv
{ _dev_env_conn :: !Connection
, _dev_env_repo_var :: !(MVar NgramsRepo)
, _dev_env_repo_saver :: !(IO ())
}
makeLenses ''DevEnv
instance HasConnection DevEnv where
connection = dev_env_conn
instance HasRepoVar DevEnv where
repoVar = dev_env_repo_var
instance HasRepoSaver DevEnv where
repoSaver = dev_env_repo_saver
newDevEnvWith :: FilePath -> IO DevEnv
newDevEnvWith file = do
param <- databaseParameters file
conn <- connect param
repo_var <- newMVar initMockRepo
repo_saver <- mkRepoSaver repo_var
pure $ DevEnv
{ _dev_env_conn = conn
, _dev_env_repo_var = repo_var
, _dev_env_repo_saver = repo_saver
}
newDevEnv :: IO DevEnv
newDevEnv = newDevEnvWith "gargantext.ini"
-- Use only for dev
-- In particular this writes the repo file after running
-- the command.
-- This function is constrained to the DevEnv rather than
-- using HasConnection and HasRepoVar.
runCmdDev :: Show err => DevEnv -> Cmd' DevEnv err a -> IO a
runCmdDev env f =
(either (fail . show) pure =<< runCmd env f)
`finally`
runReaderT saveRepo env
-- Use only for dev
runCmdDevNoErr :: DevEnv -> Cmd' DevEnv () a -> IO a
runCmdDevNoErr = runCmdDev
-- Use only for dev
runCmdDevServantErr :: DevEnv -> Cmd' DevEnv ServantErr a -> IO a
runCmdDevServantErr = runCmdDev
src/Gargantext/Database/Cooc.hs
View file @ 7da5cfa2
......@@ -20,14 +20,15 @@ module Gargantext.Database.Cooc where
import Database.PostgreSQL.Simple.SqlQQ
import Gargantext.Prelude
import Gargantext.Database.Utils (Cmd, runCmdDevNoErr, runPGSQuery)
import Gargantext.Database.Utils (Cmd, runPGSQuery)
import Gargantext.API.Settings (runCmdDevNoErr, DevEnv)
type CorpusId = Int
type MainListId = Int
type GroupListId = Int
coocTest :: IO [(Int, Int, Int)]
coocTest = runCmdDevNoErr $ dBcooc 421968 446602 446599
coocTest :: DevEnv -> IO [(Int, Int, Int)]
coocTest env = runCmdDevNoErr env $ dBcooc 421968 446602 446599
dBcooc :: CorpusId -> MainListId -> GroupListId -> Cmd err [(Int, Int, Int)]
dBcooc corpus mainList groupList = runPGSQuery [sql|
......
src/Gargantext/Database/Flow.hs
View file @ 7da5cfa2
......@@ -9,20 +9,25 @@ Portability : POSIX
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
module Gargantext.Database.Flow -- (flowDatabase, ngrams2list)
where
--import Debug.Trace (trace)
--import Control.Lens (view)
import Control.Monad (mapM_)
import Control.Monad.IO.Class (liftIO)
--import Gargantext.Core.Types
--import Gargantext.Database.Node.Contact (HyperdataContact(..))
import Data.Map (Map, lookup)
import Data.Map (Map, lookup, fromListWith, toList)
import Data.Maybe (Maybe(..), catMaybes)
import Data.Monoid
import Data.Text (Text, splitOn, intercalate)
import Data.Tuple.Extra (both)
import Data.List (concat)
......@@ -45,18 +50,31 @@ import Gargantext.Database.Schema.NodeNgram (NodeNgramPoly(..), insertNodeNgrams
import Gargantext.Database.Schema.NodeNgramsNgrams (NodeNgramsNgramsPoly(..), insertNodeNgramsNgramsNew)
import Gargantext.Database.Schema.User (getUser, UserLight(..))
import Gargantext.Database.Types.Node (HyperdataDocument(..), NodeType(..), NodeId, UserId, ListId, CorpusId, RootId, MasterCorpusId, MasterUserId)
import Gargantext.Database.Utils (Cmd)
import Gargantext.Database.Utils (Cmd, CmdM)
import Gargantext.Text.Terms (TermType(..))
import Gargantext.Ext.IMT (toSchoolName)
import Gargantext.Ext.IMTUser (deserialiseImtUsersFromFile)
import Gargantext.Prelude
import Gargantext.Text.Parsers (parseDocs, FileFormat)
import System.FilePath (FilePath)
import Gargantext.API.Ngrams (HasRepoVar)
import Servant (ServantErr)
import Gargantext.API.Ngrams (NgramsElement(..), putListNgrams, RepoCmdM)
--import Gargantext.Database.Schema.User (insertUsers, simpleUser, gargantuaUser)
import qualified Data.Map as DM
type FlowCmdM env err m =
( CmdM env err m
, RepoCmdM env err m
, HasNodeError err
, HasRepoVar env
)
flowCorpus :: HasNodeError err => FileFormat -> FilePath -> CorpusName -> Cmd err CorpusId
flowCorpus :: FlowCmdM env ServantErr m
=> FileFormat -> FilePath -> CorpusName -> m CorpusId
flowCorpus ff fp cName = do
--insertUsers [gargantuaUser, simpleUser]
hyperdataDocuments' <- map addUniqIdsDoc <$> liftIO (parseDocs ff fp)
params <- flowInsert NodeCorpus hyperdataDocuments' cName
flowCorpus' NodeCorpus hyperdataDocuments' params
......@@ -76,27 +94,6 @@ flowInsert _nt hyperdataDocuments cName = do
pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
flowAnnuaire :: HasNodeError err => FilePath -> Cmd err ()
flowAnnuaire filePath = do
contacts <- liftIO $ deserialiseImtUsersFromFile filePath
ps <- flowInsertAnnuaire "Annuaire" $ map (\h-> ToDbContact h) $ map addUniqIdsContact contacts
printDebug "length annuaire" ps
flowInsertAnnuaire :: HasNodeError err => CorpusName -> [ToDbData]
-> Cmd err ([ReturnId], UserId, CorpusId, UserId, CorpusId)
flowInsertAnnuaire name children = do
(masterUserId, _, masterCorpusId) <- subFlowCorpus userMaster corpusMasterName
ids <- insertDocuments masterUserId masterCorpusId NodeContact children
(userId, _, userCorpusId) <- subFlowAnnuaire userArbitrary name
_ <- add userCorpusId (map reId ids)
--printDebug "AnnuaireID" userCorpusId
pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
-- TODO-ACCESS:
-- check userId CanFillUserCorpus userCorpusId
-- check masterUserId CanFillMasterCorpus masterCorpusId
......@@ -104,31 +101,28 @@ flowInsertAnnuaire name children = do
-- TODO-EVENTS:
-- InsertedNgrams ?
-- InsertedNodeNgrams ?
flowCorpus' :: HasNodeError err
flowCorpus' :: FlowCmdM env err m
=> NodeType -> [HyperdataDocument]
-> ([ReturnId], UserId, CorpusId, UserId, CorpusId)
-> Cmd err CorpusId
flowCorpus' NodeCorpus hyperdataDocuments (ids,_masterUserId,_masterCorpusId, userId,userCorpusId) = do
-> m CorpusId
flowCorpus' NodeCorpus hyperdataDocuments (ids,masterUserId,masterCorpusId, userId,userCorpusId) = do
--------------------------------------------------
-- List Ngrams Flow
_userListId <- flowListUser userId userCorpusId 500
--printDebug "Working on User ListId : " userListId
let documentsWithId = mergeData (toInserted ids) (toInsert hyperdataDocuments)
-- printDebug "documentsWithId" documentsWithId
--printDebug "documentsWithId" documentsWithId
docsWithNgrams <- documentIdWithNgrams extractNgramsT documentsWithId
-- printDebug "docsWithNgrams" docsWithNgrams
--printDebug "docsWithNgrams" docsWithNgrams
let maps = mapNodeIdNgrams docsWithNgrams
-- printDebug "maps" (maps)
--printDebug "maps" (maps)
terms2id <- insertNgrams $ DM.keys maps
let indexedNgrams = DM.mapKeys (indexNgrams terms2id) maps
-- printDebug "inserted ngrams" indexedNgrams
--printDebug "inserted ngrams" indexedNgrams
_ <- insertToNodeNgrams indexedNgrams
--listId2 <- flowList masterUserId masterCorpusId indexedNgrams
--printDebug "Working on ListId : " listId2
--}
-- List Ngrams Flow
_masterListId <- flowList masterUserId masterCorpusId indexedNgrams
_userListId <- flowListUser userId userCorpusId 500
--------------------------------------------------
_ <- mkDashboard userCorpusId userId
_ <- mkGraph userCorpusId userId
......@@ -148,19 +142,22 @@ type CorpusName = Text
subFlowCorpus :: HasNodeError err => Username -> CorpusName -> Cmd err (UserId, RootId, CorpusId)
subFlowCorpus username cName = do
maybeUserId <- getUser username
userId <- case maybeUserId of
Nothing -> nodeError NoUserFound
-- mk NodeUser gargantua_id "Node Gargantua"
Just user -> pure $ userLight_id user
--printDebug "userId" userId
rootId' <- map _node_id <$> getRoot username
--printDebug "rootId'" rootId'
rootId'' <- case rootId' of
[] -> mkRoot username userId
n -> case length n >= 2 of
True -> nodeError ManyNodeUsers
False -> pure rootId'
--printDebug "rootId''" rootId''
rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
corpusId'' <- if username == userMaster
......@@ -181,32 +178,6 @@ subFlowCorpus username cName = do
pure (userId, rootId, corpusId)
subFlowAnnuaire :: HasNodeError err => Username -> CorpusName -> Cmd err (UserId, RootId, CorpusId)
subFlowAnnuaire username _cName = do
maybeUserId <- getUser username
userId <- case maybeUserId of
Nothing -> nodeError NoUserFound
-- mk NodeUser gargantua_id "Node Gargantua"
Just user -> pure $ userLight_id user
rootId' <- map _node_id <$> getRoot username
rootId'' <- case rootId' of
[] -> mkRoot username userId
n -> case length n >= 2 of
True -> nodeError ManyNodeUsers
False -> pure rootId'
rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
corpusId' <- mkAnnuaire rootId userId
corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
--printDebug "(username, userId, rootId, corpusId)"
-- (username, userId, rootId, corpusId)
pure (userId, rootId, corpusId)
------------------------------------------------------------------------
toInsert :: [HyperdataDocument] -> Map HashId HyperdataDocument
toInsert = DM.fromList . map (\d -> (maybe err identity (_hyperdataDocument_uniqId d), d))
......@@ -271,11 +242,13 @@ mapNodeIdNgrams = DM.unionsWith (DM.unionWith (DM.unionWith (+))) . fmap f
nId = documentId $ documentWithId d
------------------------------------------------------------------------
flowList :: HasNodeError err => UserId -> CorpusId
-> Map NgramsIndexed (Map NgramsType (Map NodeId Int)) -> Cmd err ListId
flowList uId cId _ngs = do
-- printDebug "ngs:" ngs
flowList :: FlowCmdM env err m => UserId -> CorpusId
-> Map NgramsIndexed (Map NgramsType (Map NodeId Int))
-> m ListId
flowList uId cId ngs = do
--printDebug "ngs:" ngs
lId <- getOrMkList cId uId
printDebug "listId flowList" lId
--printDebug "ngs" (DM.keys ngs)
-- TODO add stemming equivalence of 2 ngrams
-- TODO needs rework
......@@ -283,18 +256,21 @@ flowList uId cId _ngs = do
-- _ <- insertGroups lId groupEd
-- compute Candidate / Map
--is <- insertLists lId $ ngrams2list ngs
--printDebug "listNgrams inserted :" is
mapM_ (\(typeList, ngElmts) -> putListNgrams lId typeList ngElmts) $ toList $ ngrams2list' ngs
pure lId
flowListUser :: HasNodeError err => UserId -> CorpusId -> Int -> Cmd err NodeId
flowListUser :: FlowCmdM env err m
=> UserId -> CorpusId -> Int -> m ListId
flowListUser uId cId n = do
lId <- getOrMkList cId uId
-- is <- insertLists lId $ ngrams2list ngs
ngs <- take n <$> sortWith tficf_score <$> getTficf userMaster cId lId NgramsTerms
_ <- insertNodeNgrams [ NodeNgram lId (tficf_ngramsId ng) Nothing (ngramsTypeId NgramsTerms) (fromIntegral $ listTypeId GraphList) 1 | ng <- ngs]
ngs <- take n <$> sortWith tficf_score
<$> getTficf userMaster cId lId NgramsTerms
putListNgrams lId NgramsTerms $
[ NgramsElement (tficf_ngramsTerms ng) GraphList 1 Nothing mempty
| ng <- ngs ]
pure lId
......@@ -321,13 +297,25 @@ insertGroups lId ngrs =
------------------------------------------------------------------------
ngrams2list :: Map NgramsIndexed (Map NgramsType a)
-> [(ListType, (NgramsType,NgramsIndexed))]
-> [(ListType, (NgramsType, NgramsIndexed))]
ngrams2list m =
[ (CandidateList, (t, ng))
| (ng, tm) <- DM.toList m
, t <- DM.keys tm
]
ngrams2list' :: Map NgramsIndexed (Map NgramsType a)
-> Map NgramsType [NgramsElement]
ngrams2list' m = fromListWith (<>)
[ (t, [NgramsElement (_ngramsTerms $ _ngrams ng) CandidateList 1 Nothing mempty])
| (ng, tm) <- DM.toList m
, t <- DM.keys tm
]
-- | TODO: weight of the list could be a probability
insertLists :: HasNodeError err => ListId -> [(ListType, (NgramsType, NgramsIndexed))] -> Cmd err Int
insertLists lId lngs = insertNodeNgrams [ NodeNgram lId (_ngramsId ng) Nothing (ngramsTypeId ngt) (fromIntegral $ listTypeId l) 1
......@@ -335,3 +323,56 @@ insertLists lId lngs = insertNodeNgrams [ NodeNgram lId (_ngramsId ng) Nothing (
]
------------------------------------------------------------------------
-- | Annuaire
flowAnnuaire :: FlowCmdM env ServantErr m => FilePath -> m ()
flowAnnuaire filePath = do
contacts <- liftIO $ deserialiseImtUsersFromFile filePath
ps <- flowInsertAnnuaire "Annuaire" $ map (\h-> ToDbContact h) $ map addUniqIdsContact contacts
printDebug "length annuaire" ps
flowInsertAnnuaire :: HasNodeError err => CorpusName -> [ToDbData]
-> Cmd err ([ReturnId], UserId, CorpusId, UserId, CorpusId)
flowInsertAnnuaire name children = do
(masterUserId, _, masterCorpusId) <- subFlowCorpus userMaster corpusMasterName
ids <- insertDocuments masterUserId masterCorpusId NodeContact children
(userId, _, userCorpusId) <- subFlowAnnuaire userArbitrary name
_ <- add userCorpusId (map reId ids)
printDebug "AnnuaireID" userCorpusId
pure (ids, masterUserId, masterCorpusId, userId, userCorpusId)
subFlowAnnuaire :: HasNodeError err =>
Username -> CorpusName -> Cmd err (UserId, RootId, CorpusId)
subFlowAnnuaire username _cName = do
maybeUserId <- getUser username
userId <- case maybeUserId of
Nothing -> nodeError NoUserFound
-- mk NodeUser gargantua_id "Node Gargantua"
Just user -> pure $ userLight_id user
rootId' <- map _node_id <$> getRoot username
rootId'' <- case rootId' of
[] -> mkRoot username userId
n -> case length n >= 2 of
True -> nodeError ManyNodeUsers
False -> pure rootId'
rootId <- maybe (nodeError NoRootFound) pure (head rootId'')
corpusId' <- mkAnnuaire rootId userId
corpusId <- maybe (nodeError NoCorpusFound) pure (head corpusId')
printDebug "(username, userId, rootId, corpusId)"
(username, userId, rootId, corpusId)
pure (userId, rootId, corpusId)
src/Gargantext/Database/Lists.hs 0 → 100644
View file @ 7da5cfa2
{-|
Module : Gargantext.Database.Lists
Description : Main requests of Node to the database
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Lists where
import Control.Arrow (returnA)
import Gargantext.Core.Types -- (NodePoly(..), NodeCorpus, ListId)
import Gargantext.Core.Types.Individu (Username)
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Schema.Node -- (HasNodeError, queryNodeTable)
import Gargantext.Database.Schema.User -- (queryUserTable)
import Gargantext.Database.Utils
import Gargantext.Prelude hiding (sum, head)
import Opaleye hiding (FromField)
import Opaleye.Internal.QueryArr (Query)
import Prelude hiding (null, id, map, sum)
-- | To get all lists of a user
-- /!\ lists of different types of corpora (Annuaire or Documents)
listsWith :: HasNodeError err => Username -> Cmd err [Maybe ListId]
listsWith u = runOpaQuery (selectLists u)
where
selectLists u = proc () -> do
(auth_user,nodes) <- listsWithJoin2 -< ()
restrict -< user_username auth_user .== (pgStrictText u)
restrict -< _node_typename nodes .== (toNullable $ pgInt4 $ nodeTypeId NodeList)
returnA -< _node_id nodes
listsWithJoin2 :: Query (UserRead, NodeReadNull)
listsWithJoin2 = leftJoin queryUserTable queryNodeTable cond12
where
cond12 (u,n) = user_id u .== _node_userId n
{-
listsWithJoin3 :: Query (NodeRead, (UserRead, NodeReadNull))
listsWithJoin3 = leftJoin3 queryUserTable queryNodeTable queryNodeTable cond12 cond23
where
cond12 :: (NodeRead
cond12 (u,n) = user_id u .== _node_userId n
cond23 :: (NodeRead, (UserRead, NodeReadNull)) -> Column PGBool
cond23 (n1,(u,n2)) = (toNullable $ _node_id n1) .== _node_parentId n2
--}
src/Gargantext/Database/Metrics/TFICF.hs
View file @ 7da5cfa2
......@@ -143,4 +143,3 @@ GROUP BY nu.id,nu.terms
|]
src/Gargantext/Database/Schema/Ngrams.hs
View file @ 7da5cfa2
......@@ -25,8 +25,10 @@ Ngrams connection to the Database.
module Gargantext.Database.Schema.Ngrams where
import Data.Aeson (FromJSON, FromJSONKey)
import Control.Lens (makeLenses, view, over)
import Control.Monad (mzero)
import Data.Aeson
import Data.ByteString.Internal (ByteString)
import Data.Map (Map, fromList, lookup, fromListWith)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
......@@ -58,13 +60,11 @@ type NgramsTerms = Text
type NgramsId = Int
type Size = Int
--{-
data NgramsPoly id terms n = NgramsDb { ngrams_id :: id
, ngrams_terms :: terms
, ngrams_n :: n
} deriving (Show)
--}
type NgramsWrite = NgramsPoly (Maybe (Column PGInt4))
(Column PGText)
(Column PGInt4)
......@@ -77,7 +77,6 @@ type NgramsReadNull = NgramsPoly (Column (Nullable PGInt4))
(Column (Nullable PGText))
(Column (Nullable PGInt4))
--{-
type NgramsDb = NgramsPoly Int Text Int
$(makeAdaptorAndInstance "pNgramsDb" ''NgramsPoly)
......@@ -89,13 +88,12 @@ ngramsTable = Table "ngrams" (pNgramsDb NgramsDb { ngrams_id = optional "id"
, ngrams_n = required "n"
}
)
--{-
queryNgramsTable :: Query NgramsRead
queryNgramsTable = queryTable ngramsTable
dbGetNgramsDb :: Cmd err [NgramsDb]
dbGetNgramsDb = runOpaQuery queryNgramsTable
--}
-- | Main Ngrams Types
-- | Typed Ngrams
......@@ -104,7 +102,12 @@ dbGetNgramsDb = runOpaQuery queryNgramsTable
-- ngrams in authors field of document has Authors Type
-- ngrams in text (title or abstract) of documents has Terms Type
data NgramsType = Authors | Institutes | Sources | NgramsTerms
deriving (Eq, Show, Ord, Enum, Bounded)
deriving (Eq, Show, Ord, Enum, Bounded, Generic)
instance FromJSON NgramsType
instance FromJSONKey NgramsType
instance ToJSON NgramsType
instance ToJSONKey NgramsType
newtype NgramsTypeId = NgramsTypeId Int
deriving (Eq, Show, Ord, Num)
......
src/Gargantext/Database/Schema/Node.hs
View file @ 7da5cfa2
......@@ -155,16 +155,17 @@ instance QueryRunnerColumnDefault PGInt4 NodeId
------------------------------------------------------------------------
$(makeAdaptorAndInstance "pNode" ''NodePoly)
$(makeLensesWith abbreviatedFields ''NodePoly)
$(makeAdaptorAndInstance "pNodeSearch" ''NodePolySearch)
$(makeLensesWith abbreviatedFields ''NodePolySearch)
type NodeWrite = NodePoly (Maybe (Column PGInt4 ))
(Column PGInt4 )
(Column PGInt4 )
(Maybe (Column PGInt4 ))
(Column PGText )
type NodeWrite = NodePoly (Maybe (Column PGInt4) )
(Column PGInt4)
(Column PGInt4)
(Maybe (Column PGInt4) )
(Column PGText)
(Maybe (Column PGTimestamptz))
(Column PGJsonb )
(Column PGJsonb)
type NodeRead = NodePoly (Column PGInt4 )
(Column PGInt4 )
......@@ -174,12 +175,12 @@ type NodeRead = NodePoly (Column PGInt4 )
(Column PGTimestamptz )
(Column PGJsonb )
type NodeReadNull = NodePoly (Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGText ))
(Column (Nullable PGTimestamptz ))
type NodeReadNull = NodePoly (Column (Nullable PGInt4))
(Column (Nullable PGInt4))
(Column (Nullable PGInt4))
(Column (Nullable PGInt4))
(Column (Nullable PGText))
(Column (Nullable PGTimestamptz))
(Column (Nullable PGJsonb))
nodeTable :: Table NodeWrite NodeRead
......@@ -201,32 +202,38 @@ queryNodeTable = queryTable nodeTable
------------------------------------------------------------------------
-- | Node(Read|Write)Search is slower than Node(Write|Read) use it
-- for full text search only
type NodeSearchWrite = NodePolySearch (Maybe (Column PGInt4 ))
type NodeSearchWrite =
NodePolySearch
(Maybe (Column PGInt4) )
(Column PGInt4 )
(Column PGInt4 )
(Column (Nullable PGInt4 ))
(Column (PGText ))
(Column (Nullable PGInt4) )
(Column PGText )
(Maybe (Column PGTimestamptz))
(Column PGJsonb )
(Maybe (Column PGTSVector))
(Maybe (Column PGTSVector) )
type NodeSearchRead = NodePolySearch (Column PGInt4 )
type NodeSearchRead =
NodePolySearch
(Column PGInt4 )
(Column PGInt4 )
(Column PGInt4 )
(Column (Nullable PGInt4 ))
(Column (PGText ))
(Column PGText )
(Column PGTimestamptz )
(Column PGJsonb)
(Column PGTSVector)
type NodeSearchReadNull = NodePolySearch (Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGInt4 ))
(Column (Nullable PGText ))
(Column (Nullable PGTimestamptz ))
(Column (Nullable PGJsonb))
(Column (Nullable PGTSVector))
(Column PGJsonb )
(Column PGTSVector )
type NodeSearchReadNull =
NodePolySearch
(Column (Nullable PGInt4) )
(Column (Nullable PGInt4) )
(Column (Nullable PGInt4) )
(Column (Nullable PGInt4) )
(Column (Nullable PGText) )
(Column (Nullable PGTimestamptz))
(Column (Nullable PGJsonb) )
(Column (Nullable PGTSVector) )
--{-
nodeTableSearch :: Table NodeSearchWrite NodeSearchRead
......@@ -336,7 +343,8 @@ type JSONB = QueryRunnerColumnDefault PGJsonb
getNode :: JSONB a => NodeId -> proxy a -> Cmd err (Node a)
getNode nId _ = do
fromMaybe (error $ "Node does node exist: " <> show nId) . headMay <$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
fromMaybe (error $ "Node does node exist: " <> show nId) . headMay
<$> runOpaQuery (limit 1 $ selectNode (pgNodeId nId))
getNodesWithType :: Column PGInt4 -> Cmd err [Node HyperdataDocument]
getNodesWithType = runOpaQuery . selectNodesWithType
......@@ -502,13 +510,16 @@ childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a c
type Name = Text
-- | TODO mk all others nodes
mkNodeWithParent :: HasNodeError err => NodeType -> Maybe ParentId -> UserId -> Name -> Cmd err [NodeId]
mkNodeWithParent NodeUser (Just _) _ _ = nodeError UserNoParent
mkNodeWithParent _ Nothing _ _ = nodeError HasParent
mkNodeWithParent nt pId uId name =
insertNodesWithParentR pId [node nt name hd pId uId]
mkNodeWithParent NodeUser Nothing uId name =
insertNodesWithParentR Nothing [node NodeUser name hd Nothing uId]
where
hd = HyperdataUser . Just . pack $ show EN
mkNodeWithParent _ Nothing _ _ = nodeError HasParent
mkNodeWithParent _ _ _ _ = nodeError NotImplYet
mkRoot :: HasNodeError err => Username -> UserId -> Cmd err [RootId]
mkRoot uname uId = case uId > 0 of
......
src/Gargantext/Database/Schema/schema.sql
View file @ 7da5cfa2
CREATE EXTENSION IF NOT EXISTS plpgsql WITH SCHEMA pg_catalog;
COMMENT ON EXTENSION plpgsql IS 'PL/pgSQL procedural language';
-- needed for rights management
-- CREATE EXTENSION IF NOT EXISTS acl WITH SCHEMA public;
-- CREATE USER WITH ...
-- createdb "gargandb"
......@@ -23,6 +21,7 @@ CREATE TABLE public.auth_user (
ALTER TABLE public.auth_user OWNER TO gargantua;
-- TODO add publication_date
-- TODO typename -> type_id
CREATE TABLE public.nodes (
......@@ -40,7 +39,6 @@ CREATE TABLE public.nodes (
ALTER TABLE public.nodes OWNER TO gargantua;
CREATE TABLE public.ngrams (
id SERIAL,
terms character varying(255),
......@@ -49,7 +47,9 @@ CREATE TABLE public.ngrams (
);
ALTER TABLE public.ngrams OWNER TO gargantua;
-- TODO: delete ID
--------------------------------------------------------------
--------------------------------------------------------------
-- TODO: delete delete this table
CREATE TABLE public.nodes_ngrams (
id SERIAL,
node_id integer NOT NULL,
......@@ -64,11 +64,19 @@ CREATE TABLE public.nodes_ngrams (
-- PRIMARY KEY (node_id,ngrams_id)
);
ALTER TABLE public.nodes_ngrams OWNER TO gargantua;
--------------------------------------------------------------
CREATE TABLE public.nodes_ngrams_repo (
version integer NOT NULL,
patches jsonb DEFAULT '{}'::jsonb NOT NULL,
PRIMARY KEY (version)
);
ALTER TABLE public.nodes_ngrams_repo OWNER TO gargantua;
--------------------------------------------------------------
--
-- Name: nodes_ngrams_ngrams; Type: TABLE; Schema: public; Owner: gargantua
--
-- TODO: delete delete this table
CREATE TABLE public.nodes_ngrams_ngrams (
node_id integer NOT NULL REFERENCES public.nodes(id) ON DELETE CASCADE,
ngram1_id integer NOT NULL REFERENCES public.ngrams(id) ON DELETE CASCADE,
......@@ -79,7 +87,7 @@ CREATE TABLE public.nodes_ngrams_ngrams (
ALTER TABLE public.nodes_ngrams_ngrams OWNER TO gargantua;
---------------------------------------------------------
CREATE TABLE public.nodes_nodes (
node1_id integer NOT NULL,
node2_id integer NOT NULL,
......@@ -89,8 +97,23 @@ CREATE TABLE public.nodes_nodes (
PRIMARY KEY (node1_id, node2_id)
);
ALTER TABLE public.nodes_nodes OWNER TO gargantua;
---------------------------------------------------------
-- If needed for rights management at row level
-- CREATE EXTENSION IF NOT EXISTS acl WITH SCHEMA public;
CREATE TABLE public.rights (
user_id INTEGER NOT NULL REFERENCES public.auth_user(id) ON DELETE CASCADE,
node_id INTEGER NOT NULL REFERENCES public.nodes(id) ON DELETE CASCADE,
rights INTEGER NOT NULL,
PRIMARY KEY (user_id, node_id)
);
ALTER TABLE public.rights OWNER TO gargantua;
CREATE INDEX rights_userId_nodeId ON public.rights USING btree (user_id,node_id);
------------------------------------------------------------
-- INDEXES
CREATE UNIQUE INDEX ON public.auth_user(username);
......
src/Gargantext/Database/Types/Node.hs
View file @ 7da5cfa2
......@@ -28,8 +28,7 @@ import Prelude (Enum, Bounded, minBound, maxBound)
import GHC.Generics (Generic)
import Control.Lens hiding (elements)
import qualified Control.Lens as L
import Control.Lens hiding (elements, (&))
import Control.Applicative ((<*>))
import Control.Monad (mzero)
......@@ -41,7 +40,7 @@ import Data.ByteString.Lazy (ByteString)
import Data.Either
import Data.Eq (Eq)
import Data.Monoid (mempty)
import Data.Text (Text, unpack)
import Data.Text (Text, unpack, pack)
import Data.Time (UTCTime)
import Data.Time.Segment (jour, timesAfter, Granularity(D))
import Data.Swagger
......@@ -61,7 +60,7 @@ import Gargantext.Core.Utils.Prefix (unPrefix)
--import Gargantext.Database.Utils
------------------------------------------------------------------------
newtype NodeId = NodeId Int
deriving (Show, Read, Generic, Num, Eq, Ord, Enum)
deriving (Show, Read, Generic, Num, Eq, Ord, Enum, ToJSONKey, FromJSONKey, ToJSON, FromJSON)
instance ToField NodeId where
toField (NodeId n) = toField n
......@@ -72,8 +71,6 @@ instance FromField NodeId where
if (n :: Int) > 0 then return $ NodeId n
else mzero
instance ToJSON NodeId
instance FromJSON NodeId
instance ToSchema NodeId
instance FromHttpApiData NodeId where
......@@ -237,11 +234,8 @@ instance ToSchema Event where
declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
------------------------------------------------------------------------
type Text' = Text
instance Arbitrary Text' where
arbitrary = elements ["ici", "la"]
instance Arbitrary Text where
arbitrary = elements $ map (\c -> pack [c]) ['a'..'z']
data Resource = Resource { resource_path :: Maybe Text
, resource_scraper :: Maybe Text
......@@ -324,6 +318,10 @@ data HyperdataList = HyperdataList { hyperdataList_preferences :: Maybe Text
$(deriveJSON (unPrefix "hyperdataList_") ''HyperdataList)
instance Hyperdata HyperdataList
instance Arbitrary HyperdataList where
arbitrary = elements [HyperdataList (Just "from list A")]
------------------------------------------------------------------------
data HyperdataScore = HyperdataScore { hyperdataScore_preferences :: Maybe Text
} deriving (Show, Generic)
......@@ -500,27 +498,24 @@ docExample = "{\"doi\":\"sdfds\",\"publication_day\":6,\"language_iso2\":\"en\",
instance ToSchema HyperdataCorpus where
declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
L.& mapped.schema.description ?~ "a corpus"
L.& mapped.schema.example ?~ toJSON hyperdataCorpus
& mapped.schema.description ?~ "a corpus"
& mapped.schema.example ?~ toJSON hyperdataCorpus
instance ToSchema HyperdataAnnuaire where
declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
L.& mapped.schema.description ?~ "an annuaire"
L.& mapped.schema.example ?~ toJSON hyperdataAnnuaire
& mapped.schema.description ?~ "an annuaire"
& mapped.schema.example ?~ toJSON hyperdataAnnuaire
instance ToSchema HyperdataDocument where
declareNamedSchema proxy = genericDeclareNamedSchema defaultSchemaOptions proxy
L.& mapped.schema.description ?~ "a document"
L.& mapped.schema.example ?~ toJSON hyperdataDocument
& mapped.schema.description ?~ "a document"
& mapped.schema.example ?~ toJSON hyperdataDocument
instance ToSchema HyperdataAny where
declareNamedSchema proxy =
pure $ genericNameSchema defaultSchemaOptions proxy mempty
L.& schema.description ?~ "a node"
L.& schema.example ?~ emptyObject -- TODO
& schema.description ?~ "a node"
& schema.example ?~ emptyObject -- TODO
instance ToSchema hyperdata =>
......
src/Gargantext/Database/Utils.hs
View file @ 7da5cfa2
......@@ -37,7 +37,6 @@ import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(Conversion
import Database.PostgreSQL.Simple.Internal (Field)
import Gargantext.Prelude
import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
import Servant (ServantErr)
import System.IO (FilePath)
import Text.Read (read)
import qualified Data.ByteString as DB
......@@ -49,13 +48,19 @@ class HasConnection env where
instance HasConnection Connection where
connection = identity
type CmdM env err m =
type CmdM' env err m =
( MonadReader env m
, HasConnection env
, MonadError err m
, MonadIO m
)
type CmdM env err m =
( CmdM' env err m
, HasConnection env
)
type Cmd' env err a = forall m. CmdM' env err m => m a
type Cmd err a = forall m env. CmdM env err m => m a
-- TODO: ideally there should be very few calls to this functions.
......@@ -64,22 +69,10 @@ mkCmd k = do
conn <- view connection
liftIO $ k conn
runCmd :: Connection -> Cmd err a -> IO (Either err a)
runCmd conn m = runExceptT $ runReaderT m conn
-- Use only for dev
runCmdDevWith :: FilePath -> Cmd ServantErr a -> IO a
runCmdDevWith fp f = do
conn <- connectGargandb fp
either (fail . show) pure =<< runCmd conn f
-- Use only for dev
runCmdDev :: Cmd ServantErr a -> IO a
runCmdDev = runCmdDevWith "gargantext.ini"
-- Use only for dev
runCmdDevNoErr :: Cmd () a -> IO a
runCmdDevNoErr = runCmdDevWith "gargantext.ini"
runCmd :: HasConnection env => env
-> Cmd' env err a
-> IO (Either err a)
runCmd env m = runExceptT $ runReaderT m env
runOpaQuery :: Default FromFields fields haskells => Select fields -> Cmd err [haskells]
runOpaQuery q = mkCmd $ \c -> runQuery c q
......
src/Gargantext/Text/Flow.hs
View file @ 7da5cfa2
......@@ -43,6 +43,7 @@ import Gargantext.Text.Terms (TermType, extractTerms)
import Gargantext.Viz.Graph (Graph(..), data2graph)
import Gargantext.Viz.Graph.Bridgeness (bridgeness)
import Gargantext.Viz.Graph.Distances.Matrice (measureConditional)
--import Gargantext.Viz.Graph.Distances.Matrice (distributional)
import Gargantext.Viz.Graph.Index (createIndices, toIndex, map2mat, mat2map)
{-
____ _ _
......
src/Gargantext/Text/Metrics.hs
View file @ 7da5cfa2
......@@ -63,7 +63,7 @@ filterCooc' (FilterConfig _ _ _ _ (DefaultValue dv)) ts m = trace ("coocScored "
where
selection = [(x,y) | x <- ts
, y <- ts
-- , x >= y
, x > y
]
......
src/Gargantext/Viz/Phylo.hs
View file @ 7da5cfa2
......@@ -7,7 +7,7 @@ Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Specifications of Phylomemy format.
Specifications of Phylomemy export format.
Phylomemy can be described as a Temporal Graph with different scale of
granularity of group of ngrams (terms and multi-terms).
......@@ -39,9 +39,9 @@ import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Prelude
------------------------------------------------------------------------
data PhyloFormat =
PhyloFormat { _phyloFormat_param :: PhyloParam
, _phyloFormat_data :: Phylo
data PhyloExport =
PhyloExport { _phyloExport_param :: PhyloParam
, _phyloExport_data :: Phylo
} deriving (Generic)
-- | .phylo parameters
......@@ -66,7 +66,7 @@ data Software =
-- Ngrams : list of all (possible) terms contained in the phylomemy (with their id)
-- Steps : list of all steps to build the phylomemy
data Phylo =
Phylo { _phylo_puration :: (Start, End)
Phylo { _phylo_duration :: (Start, End)
, _phylo_ngrams :: [Ngram]
, _phylo_periods :: [PhyloPeriod]
}
......@@ -109,27 +109,28 @@ type PhyloLevelId = (PhyloPeriodId, Int)
-- Ngrams: set of terms that build the group
-- Period Parents|Childs: weighted link to Parents|Childs (Temporal Period axis)
-- Level Parents|Childs: weighted link to Parents|Childs (Level Granularity axis)
-- Pointers are directed link from Self to any PhyloGroup (/= Self ?)
data PhyloGroup =
PhyloGroup { _phylo_groupId :: PhyloGroupId
, _phylo_groupLabel :: Maybe Text
, _phylo_groupNgrams :: [NgramsId]
, _phylo_groupPeriodParents :: [Edge]
, _phylo_groupPeriodChilds :: [Edge]
, _phylo_groupPeriodParents :: [Pointer]
, _phylo_groupPeriodChilds :: [Pointer]
, _phylo_groupLevelParents :: [Edge]
, _phylo_groupLevelChilds :: [Edge]
, _phylo_groupLevelParents :: [Pointer]
, _phylo_groupLevelChilds :: [Pointer]
}
deriving (Generic)
type PhyloGroupId = (PhyloLevelId, Int)
type Edge = (PhyloGroupId, Weight)
type Pointer = (PhyloGroupId, Weight)
type Weight = Double
-- | Lenses
makeLenses ''Phylo
makeLenses ''PhyloParam
makeLenses ''PhyloFormat
makeLenses ''PhyloExport
makeLenses ''Software
-- | JSON instances
......@@ -140,7 +141,7 @@ $(deriveJSON (unPrefix "_phylo_group" ) ''PhyloGroup )
--
$(deriveJSON (unPrefix "_software_" ) ''Software )
$(deriveJSON (unPrefix "_phyloParam_" ) ''PhyloParam )
$(deriveJSON (unPrefix "_phyloFormat_" ) ''PhyloFormat )
$(deriveJSON (unPrefix "_phyloExport_" ) ''PhyloExport )
-- | TODO XML instances
src/Gargantext/Viz/Phylo/Tools.hs 0 → 100644
View file @ 7da5cfa2
{-|
Module : Gargantext.Viz.Phylo.Tools
Description : Phylomemy tools
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Phylo Toolbox:
- functions to build a Phylo
- functions to filter the cliques
- functions to manage a Phylo
Group Functions (TODO list)
- cohesion sur un groupe
- distance au dernier branchement
- âge du groupe
Futre Idea: temporal zoom on Phylo
phyloZoomOut :: (PeriodGrain, Phylo) -> [(PeriodGrain, Phylo)]
(from smallest granularity, it increases (zoom out) the periods of the Phylo)
Moral idea: viz from out to in
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Gargantext.Viz.Phylo.Tools where
import Data.Set (Set)
import Data.Map (Map)
import Data.Map as Map hiding (Map)
import Gargantext.Prelude
import Gargantext.Viz.Phylo
import Gargantext.Viz.Phylo.Example
-- | Some types to help reading
type Clique = Set Ngrams
type Support = Int
type MinSize = Int
-- | Building a phylo
-- (Indicative and schematic function)
buildPhylo :: Support -> MinSize
-> Map Clique Support -> Phylo
buildPhylo s m mcs = level2Phylo
. groups2level
. clusters2group
. map clique2cluster
. filterCliques s m
level2Phylo :: PhyloLevel -> Phylo -> Phylo
level2Phylo = undefined
groups2level :: [PhyloGroup] -> PhyloLevel
groups2level = undefined
clusters2group :: [Cluster Ngrams] -> PhyloGroup
clusters2group = undefined
clique2cluster :: Clique -> Cluster Ngrams
clique2cluster = undefined
-- | Filtering the cliques before bulding the Phylo
-- (Support and MinSize as parameter of the finale function to build a phylo)
-- idea: log of Corpus size (of docs)
filterCliques :: Support -> MinSize
-> Map Clique Support -> [Clique]
filterCliques s ms = maximalCliques
. filterWithSizeSet ms
. Map.keys
. filterWithSupport s
-- | Hapaxify / Threshold
-- hapax s = 1
-- ?
filterWithSupport :: Support -> Map Clique Support -> Map Clique Support
filterWithSupport s = Map.filter (>s)
filterWithSizeSet :: MinSize -> [Clique] -> [Clique]
filterWithSizeSet = undefined
-- | filtre les cliques de ngrams compris dans une clique plus grande
-- /!\ optim inside
maximalCliques :: [Clique] -> [Clique]
maximalCliques = undefined
-- | Phylo management
-- | PhyloLevel Management
viewGroups :: (Start,End) -> PhyloLevel -> Phylo -> [PhyloGroup]
viewGroups = undefined
viewLevels :: (Start,End) -> Phylo -> [PhyloLevel]
viewLevels = undefined
-- | tous les terme des champs, tous les parents et les enfants
setGroup :: PhyloGroup -> PhyloGroup -> PhyloGroup
setGroup = undefined
--removeTerms :: recalculer les cliques pour ces termes
--addTerms
stack.yaml
View file @ 7da5cfa2
......@@ -12,6 +12,8 @@ packages:
allow-newer: true
extra-deps:
- json-state-0.1.0.1
- time-units-1.0.0
- git: https://github.com/delanoe/data-time-segment.git
commit: 4e3d57d80e9dfe6624c8eeaa8595fc8fe64d8723
- git: https://gitlab.iscpif.fr/gargantext/hlcm.git
......@@ -34,4 +36,4 @@ extra-deps:
- servant-flatten-0.2
- servant-multipart-0.11.2
- stemmer-0.5.2
- validity-0.8.0.0 # patches-{map,class}
- validity-0.9.0.0 # patches-{map,class}
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