Skip to content

H
haskell-gargantext
Unverified Commit b13b85bf authored by Nicolas Pouillard's avatar Nicolas Pouillard
Browse files
Options

[Database] Refactor functions accessing the database

parent 6fdb2550
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 556 additions and 559 deletions
src/Gargantext/API.hs
View file @ b13b85bf
......@@ -24,6 +24,7 @@ Thanks @yannEsposito for this.
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
......@@ -37,14 +38,14 @@ module Gargantext.API
where
---------------------------------------------------------------------
import Database.PostgreSQL.Simple (Connection)
import System.IO (FilePath)
import GHC.Generics (D1, Meta (..), Rep)
import GHC.TypeLits (AppendSymbol, Symbol)
import Control.Lens
import Control.Monad.IO.Class (liftIO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (runReaderT)
import Data.Aeson.Encode.Pretty (encodePretty)
import qualified Data.ByteString.Lazy.Char8 as BL8
import Data.Swagger
......@@ -70,8 +71,9 @@ import Text.Blaze.Html (Html)
import Gargantext.Prelude
import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer)
import Gargantext.API.Auth (AuthRequest, AuthResponse, auth')
import Gargantext.API.Node ( Roots , roots
import Gargantext.API.Auth (AuthRequest, AuthResponse, auth)
import Gargantext.API.Node ( GargServer
, Roots , roots
, NodeAPI , nodeAPI
, NodesAPI , nodesAPI
, GraphAPI , graphAPI
......@@ -208,9 +210,6 @@ type GargAPI = "api" :> Summary "API " :> GargAPIVersion
type GargAPIVersion = "v1.0" :> Summary "v1.0: " :> GargAPI'
auth :: Connection -> AuthRequest -> Handler AuthResponse
auth conn ar = liftIO $ auth' conn ar
type GargAPI' =
-- Auth endpoint
"auth" :> Summary "AUTH API"
......@@ -277,27 +276,24 @@ type API = SwaggerFrontAPI :<|> GargAPI :<|> Get '[HTML] Html
server :: Env -> IO (Server API)
server env = do
gargAPI <- serverGargAPI env
-- orchestrator <- scrapyOrchestrator env
pure $ swaggerFront
:<|> gargAPI
:<|> hoistServer (Proxy :: Proxy GargAPI) (`runReaderT` env) serverGargAPI
:<|> serverIndex
serverGargAPI :: Env -> IO (Server GargAPI)
serverGargAPI env = do
-- orchestrator <- scrapyOrchestrator env
pure $ auth conn
:<|> roots conn
:<|> nodeAPI conn (Proxy :: Proxy HyperdataAny)
:<|> nodeAPI conn (Proxy :: Proxy HyperdataCorpus)
:<|> nodeAPI conn (Proxy :: Proxy HyperdataAnnuaire)
:<|> nodesAPI conn
serverGargAPI :: GargServer GargAPI
serverGargAPI -- orchestrator
= auth
:<|> roots
:<|> nodeAPI (Proxy :: Proxy HyperdataAny)
:<|> nodeAPI (Proxy :: Proxy HyperdataCorpus)
:<|> nodeAPI (Proxy :: Proxy HyperdataAnnuaire)
:<|> nodesAPI
:<|> count -- TODO: undefined
:<|> search conn
:<|> graphAPI conn -- TODO: mock
:<|> treeAPI conn
:<|> search
:<|> graphAPI -- TODO: mock
:<|> treeAPI
-- :<|> orchestrator
where
conn = env ^. env_conn
serverIndex :: Server (Get '[HTML] Html)
serverIndex = $(do (Just s) <- liftIO (fileTypeToFileTree (FileTypeFile "purescript-gargantext/dist/index.html"))
......
src/Gargantext/API/Auth.hs
View file @ b13b85bf
......@@ -22,6 +22,7 @@ Main authorisation of Gargantext are managed in this module
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.API.Auth
......@@ -31,11 +32,11 @@ import Data.Aeson.TH (deriveJSON)
import Data.List (elem)
import Data.Swagger
import Data.Text (Text, reverse)
import Database.PostgreSQL.Simple (Connection)
import GHC.Generics (Generic)
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Root (getRoot)
import Gargantext.Database.Types.Node (NodePoly(_node_id))
import Gargantext.Database.Utils (Cmd)
import Gargantext.Prelude hiding (reverse)
import Test.QuickCheck (elements, oneof)
import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)
......@@ -81,17 +82,17 @@ arbitraryUsername = ["gargantua", "user1", "user2"]
arbitraryPassword :: [Password]
arbitraryPassword = map reverse arbitraryUsername
checkAuthRequest :: Username -> Password -> Connection -> IO CheckAuth
checkAuthRequest u p c
checkAuthRequest :: Username -> Password -> Cmd err CheckAuth
checkAuthRequest u p
| not (u `elem` arbitraryUsername) = pure InvalidUser
| u /= reverse p = pure InvalidPassword
| otherwise = do
muId <- getRoot u c
muId <- getRoot u
pure $ maybe InvalidUser (Valid "token" . _node_id) $ head muId
auth' :: Connection -> AuthRequest -> IO AuthResponse
auth' c (AuthRequest u p) = do
checkAuthRequest' <- checkAuthRequest u p c
auth :: AuthRequest -> Cmd err AuthResponse
auth (AuthRequest u p) = do
checkAuthRequest' <- checkAuthRequest u p
case checkAuthRequest' of
InvalidUser -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid user")
InvalidPassword -> pure $ AuthResponse Nothing (Just $ AuthInvalid "Invalid password")
......
src/Gargantext/API/Count.hs
View file @ b13b85bf
......@@ -146,5 +146,5 @@ instance ToSchema Count
-- arbitrary = Count <$> arbitrary <*> arbitrary <*> arbitrary
-----------------------------------------------------------------------
count :: Query -> Handler Counts
count :: Monad m => Query -> m Counts
count _ = undefined
src/Gargantext/API/Ngrams.hs
View file @ b13b85bf
......@@ -28,6 +28,7 @@ add get
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS -fno-warn-orphans #-}
module Gargantext.API.Ngrams
......@@ -35,6 +36,7 @@ module Gargantext.API.Ngrams
import Prelude (round)
-- import Gargantext.Database.Schema.User (UserId)
import Data.Functor (($>))
import Data.Patch.Class (Replace, replace)
--import qualified Data.Map.Strict.Patch as PM
import Data.Monoid
......@@ -42,24 +44,26 @@ import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
--import Data.Maybe (catMaybes)
--import qualified Data.Map.Strict as DM
-- import qualified Data.Map.Strict as DM
import Data.Map.Strict (Map)
--import qualified Data.Set as Set
import Control.Lens ((.~))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Lens (Prism', prism', (.~), (#))
import Control.Monad (guard)
import Control.Monad.Error.Class (MonadError, throwError)
import Data.Aeson
import Data.Aeson.TH (deriveJSON)
import Data.Either(Either(Left))
import Data.Map (lookup)
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import Data.Swagger
import Data.Swagger hiding (version)
import Data.Text (Text)
import Database.PostgreSQL.Simple (Connection)
import GHC.Generics (Generic)
--import Gargantext.Core.Types.Main (Tree(..))
import Gargantext.Core.Utils.Prefix (unPrefix)
import Gargantext.Database.Types.Node (NodeType(..))
import Gargantext.Database.Schema.Node (defaultList)
import Gargantext.Database.Schema.Node (defaultList, HasNodeError)
import qualified Gargantext.Database.Schema.Ngrams as Ngrams
import Gargantext.Database.Utils (Cmd)
import Gargantext.Prelude
import Gargantext.Core.Types (ListType(..), ListId, CorpusId, Limit, Offset)
import Prelude (Enum, Bounded, minBound, maxBound)
......@@ -184,27 +188,18 @@ instance ToSchema NgramsPatch
instance Arbitrary NgramsPatch where
arbitrary = NgramsPatch <$> arbitrary <*> (replace <$> arbitrary <*> arbitrary)
data NgramsIdPatch =
NgramsIdPatch { _nip_ngrams :: NgramsTerm
, _nip_ngramsPatch :: NgramsPatch
}
deriving (Ord, Eq, Show, Generic)
$(deriveJSON (unPrefix "_nip_") ''NgramsIdPatch)
instance ToSchema NgramsIdPatch
instance Arbitrary NgramsIdPatch where
arbitrary = NgramsIdPatch <$> arbitrary <*> arbitrary
--
-- TODO:
-- * This should be a Map NgramsId NgramsPatch
-- * Patchs -> Patches
newtype NgramsIdPatchs =
NgramsIdPatchs { _nip_ngramsIdPatchs :: [NgramsIdPatch] }
newtype NgramsTablePatch =
NgramsTablePatch { _nip_ngramsIdPatchs :: Map NgramsTerm NgramsPatch }
deriving (Ord, Eq, Show, Generic, Arbitrary)
$(deriveJSON (unPrefix "_nip_") ''NgramsIdPatchs)
instance ToSchema NgramsIdPatchs
$(deriveJSON (unPrefix "_nip_") ''NgramsTablePatch)
instance ToSchema NgramsTablePatch
-- TODO: replace by mempty once we have the Monoid instance
emptyNgramsTablePatch :: NgramsTablePatch
emptyNgramsTablePatch = NgramsTablePatch mempty
------------------------------------------------------------------------
------------------------------------------------------------------------
......@@ -246,22 +241,34 @@ type TableNgramsApiGet = Summary " Table Ngrams API Get"
type TableNgramsApi = Summary " Table Ngrams API Change"
:> QueryParam "list" ListId
:> ReqBody '[JSON] NgramsIdPatchsFeed -- Versioned ...
:> Put '[JSON] NgramsIdPatchsBack -- Versioned ...
:> ReqBody '[JSON] NgramsTablePatch -- (Versioned NgramsTablePatch)
:> Put '[JSON] NgramsTablePatch -- (Versioned NgramsTablePatch)
type NgramsIdPatchsFeed = NgramsIdPatchs
type NgramsIdPatchsBack = NgramsIdPatchs
data NgramError = UnsupportedVersion
deriving (Show)
class HasNgramError e where
_NgramError :: Prism' e NgramError
instance HasNgramError ServantErr where
_NgramError = prism' make match
where
err = err500 { errBody = "NgramError: Unsupported version" }
make UnsupportedVersion = err
match e = guard (e == err) $> UnsupportedVersion
ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
ngramError nne = throwError $ _NgramError # nne
{-
toLists :: ListId -> NgramsIdPatchs -> [(ListId, NgramsId, ListTypeId)]
toLists :: ListId -> NgramsTablePatch -> [(ListId, NgramsId, ListTypeId)]
-- toLists = undefined
toLists lId np = [ (lId,ngId,listTypeId lt) | map (toList lId) (_nip_ngramsIdPatchs np) ]
toList :: ListId -> NgramsIdPatch -> (ListId, NgramsId, ListTypeId)
toList = undefined
toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatchs -> [NodeNgramsNgrams]
toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsTablePatch -> [NodeNgramsNgrams]
toGroups lId addOrRem ps = concat $ map (toGroup lId addOrRem) $ _nip_ngramsIdPatchs ps
toGroup :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatch -> [NodeNgramsNgrams]
......@@ -271,26 +278,37 @@ toGroup lId addOrRem (NgramsIdPatch ngId patch) =
-}
tableNgramsPatch :: Connection -> CorpusId -> Maybe ListId -> NgramsIdPatchsFeed -> IO NgramsIdPatchsBack
tableNgramsPatch = undefined
-- Apply the given patch to the DB and returns the patch to be applied on the
-- cilent.
-- 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 ListId
-- -> Versioned NgramsTablePatch
-- -> Cmd err (Versioned NgramsTablePatch)
-> any
-> Cmd err any
tableNgramsPatch _ _ _ = undefined
{-
tableNgramsPatch conn corpusId maybeList patchs = do
listId <- case maybeList of
Nothing -> defaultList conn corpusId
Just listId' -> pure listId'
_ <- ngramsGroup' conn Add $ toGroups listId _np_add_children patchs
_ <- ngramsGroup' conn Del $ toGroups listId _np_rem_children patchs
_ <- updateNodeNgrams conn (toLists listId patchs)
pure (NgramsIdPatchs [])
tableNgramsPatch corpusId maybeList (Versioned version _patch) = do
when (version /= 1) $ ngramError UnsupportedVersion
_listId <- maybe (defaultList corpusId) pure maybeList
{-
_ <- ngramsGroup' Add $ toGroups listId _np_add_children patch
_ <- ngramsGroup' Del $ toGroups listId _np_rem_children patch
_ <- updateNodeNgrams (toLists listId patch)
-}
pure $ Versioned 1 emptyNgramsTablePatch
-}
-- | TODO Errors management
-- TODO: polymorphic for Annuaire or Corpus or ...
getTableNgrams :: MonadIO m
=> Connection -> CorpusId -> Maybe TabType
getTableNgrams :: HasNodeError err
=> CorpusId -> Maybe TabType
-> Maybe ListId -> Maybe Limit -> Maybe Offset
-> m NgramsTable
getTableNgrams c cId maybeTabType maybeListId mlimit moffset = liftIO $ do
-> Cmd err NgramsTable
getTableNgrams cId maybeTabType maybeListId mlimit moffset = do
let lieu = "Garg.API.Ngrams: " :: Text
let ngramsType = case maybeTabType of
Nothing -> Ngrams.Sources -- panic (lieu <> "Indicate the Table")
......@@ -301,9 +319,7 @@ getTableNgrams c cId maybeTabType maybeListId mlimit moffset = liftIO $ do
Terms -> Ngrams.NgramsTerms
_ -> panic $ lieu <> "No Ngrams for this tab"
listId <- case maybeListId of
Nothing -> defaultList c cId
Just lId -> pure lId
listId <- maybe (defaultList cId) pure maybeListId
let
defaultLimit = 10 -- TODO
......@@ -311,7 +327,7 @@ getTableNgrams c cId maybeTabType maybeListId mlimit moffset = liftIO $ do
offset_ = maybe 0 identity moffset
(ngramsTableDatas, mapToParent, mapToChildren) <-
Ngrams.getNgramsTableDb c NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
Ngrams.getNgramsTableDb NodeDocument ngramsType (Ngrams.NgramsTableParam listId cId) limit_ offset_
-- printDebug "ngramsTableDatas" ngramsTableDatas
......
src/Gargantext/API/Node.hs
View file @ b13b85bf
This diff is collapsed.
src/Gargantext/API/Search.hs
View file @ b13b85bf
......@@ -19,17 +19,16 @@ Count API part of Gargantext.
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.API.Search
where
import GHC.Generics (Generic)
import Data.Time (UTCTime)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson.TH (deriveJSON)
import Data.Swagger
import Data.Text (Text)
import Database.PostgreSQL.Simple (Connection)
import Servant
import Test.QuickCheck.Arbitrary
import Test.QuickCheck (elements)
......@@ -40,6 +39,7 @@ import Gargantext.Core.Types.Main (Offset, Limit)
import Gargantext.Database.Types.Node
import Gargantext.Database.TextSearch
import Gargantext.Database.Facet
import Gargantext.Database.Utils (Cmd)
-----------------------------------------------------------------------
-- | SearchIn [NodesId] if empty then global search
......@@ -88,12 +88,12 @@ instance ToSchema SearchResults where
type SearchAPI = Post '[JSON] SearchResults
-----------------------------------------------------------------------
search :: Connection -> SearchQuery -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Handler SearchResults
search c (SearchQuery q pId) o l order =
liftIO $ SearchResults <$> searchInCorpusWithContacts c pId q o l order
search :: SearchQuery -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err SearchResults
search (SearchQuery q pId) o l order =
SearchResults <$> searchInCorpusWithContacts pId q o l order
searchIn :: Connection -> NodeId -> SearchInQuery -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Handler SearchResults
searchIn c nId (SearchInQuery q ) o l order =
liftIO $ SearchResults <$> searchInCorpusWithContacts c nId q o l order
searchIn :: NodeId -> SearchInQuery -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err SearchResults
searchIn nId (SearchInQuery q ) o l order =
SearchResults <$> searchInCorpusWithContacts nId q o l order
src/Gargantext/API/Settings.hs
View file @ b13b85bf
......@@ -48,7 +48,7 @@ import qualified Jose.Jwa as Jose
import Control.Monad.Logger
import Control.Lens
import Gargantext.Prelude
import Gargantext.Database.Utils (databaseParameters)
import Gargantext.Database.Utils (databaseParameters, HasConnection(..))
import Gargantext.API.Orchestrator.Types
type PortNumber = Int
......@@ -136,6 +136,9 @@ data Env = Env
makeLenses ''Env
instance HasConnection Env where
connection = env_conn
data MockEnv = MockEnv
{ _menv_firewall :: !FireWall
}
......
src/Gargantext/Database.hs
View file @ b13b85bf
......@@ -18,12 +18,8 @@ Gargantext's database.
module Gargantext.Database ( module Gargantext.Database.Utils
, module Gargantext.Database.Bashql
, Connection
)
where
import Gargantext.Database.Utils (connectGargandb)
import Gargantext.Database.Bashql
import Database.PostgreSQL.Simple (Connection)
src/Gargantext/Database/Bashql.hs
View file @ b13b85bf
......@@ -59,6 +59,7 @@ AMS, and by SIAM.
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Bashql ( get
, ls
......@@ -70,7 +71,6 @@ module Gargantext.Database.Bashql ( get
, rename
, tree
-- , mkCorpus, mkAnnuaire
, runCmd'
)
where
......@@ -80,51 +80,49 @@ import Data.Text (Text)
import Data.List (concat, last)
import Gargantext.Core.Types
import Gargantext.Database.Utils (connectGargandb, Cmd(..), runCmd, mkCmd)
import Gargantext.Database.Utils (runOpaQuery, Cmd)
import Gargantext.Database.Schema.Node
import qualified Gargantext.Database.Node.Update as U (Update(..), update)
import Gargantext.Prelude
import Opaleye hiding (FromField)
-- List of NodeId
-- type PWD a = PWD UserId [a]
type PWD = [NodeId]
--data PWD' a = a | PWD' [a]
rename :: NodeId -> Text -> Cmd [Int]
rename n t = mkCmd $ \conn -> U.update (U.Rename n t) conn
rename :: NodeId -> Text -> Cmd err [Int]
rename n t = U.update $ U.Rename n t
mv :: NodeId -> ParentId -> Cmd [Int]
mv n p = mkCmd $ \conn -> U.update (U.Move n p) conn
mv :: NodeId -> ParentId -> Cmd err [Int]
mv n p = U.update $ U.Move n p
-- | TODO get Children or Node
get :: PWD -> Cmd [NodeAny]
get :: PWD -> Cmd err [NodeAny]
get [] = pure []
get pwd = Cmd . ReaderT $ \conn -> runQuery conn $ selectNodesWithParentID (last pwd)
get pwd = runOpaQuery $ selectNodesWithParentID (last pwd)
-- | Home, need to filter with UserId
home :: Cmd PWD
home = map _node_id <$> Cmd (ReaderT (getNodesWithParentId 0 Nothing))
home :: Cmd err PWD
home = map _node_id <$> getNodesWithParentId 0 Nothing
-- | ls == get Children
ls :: PWD -> Cmd [NodeAny]
ls :: PWD -> Cmd err [NodeAny]
ls = get
tree :: PWD -> Cmd [NodeAny]
tree :: PWD -> Cmd err [NodeAny]
tree p = do
ns <- get p
children <- mapM (\n -> get [_node_id n]) ns
pure $ ns <> concat children
-- | TODO
post :: PWD -> [NodeWrite'] -> Cmd Int64
post :: PWD -> [NodeWrite'] -> Cmd err Int64
post [] _ = pure 0
post _ [] = pure 0
post pth ns = Cmd . ReaderT $ insertNodesWithParent (Just $ last pth) ns
post pth ns = insertNodesWithParent (Just $ last pth) ns
--postR :: PWD -> [NodeWrite'] -> Cmd [Int]
--postR :: PWD -> [NodeWrite'] -> Cmd err [Int]
--postR [] _ _ = pure [0]
--postR _ [] _ = pure [0]
--postR pth ns c = mkNodeR (last pth) ns c
......@@ -132,15 +130,15 @@ post pth ns = Cmd . ReaderT $ insertNodesWithParent (Just $ last pth) ns
-- | WIP
-- rm : mv to trash
-- del : empty trash
--rm :: Connection -> PWD -> [NodeId] -> IO Int
--rm :: PWD -> [NodeId] -> IO Int
--rm = del
del :: [NodeId] -> Cmd Int
del :: [NodeId] -> Cmd err Int
del [] = pure 0
del ns = deleteNodes ns
-- | TODO
put :: U.Update -> Cmd [Int]
put u = mkCmd $ U.update u
put :: U.Update -> Cmd err [Int]
put = U.update
-- | TODO
-- cd (Home UserId) | (Node NodeId)
......@@ -151,7 +149,7 @@ put u = mkCmd $ U.update u
-- type Name = Text
--mkCorpus :: ToJSON a => Name -> (a -> Text) -> [a] -> Cmd NewNode
--mkCorpus :: ToJSON a => Name -> (a -> Text) -> [a] -> Cmd err NewNode
--mkCorpus name title ns = do
-- pid <- home
--
......@@ -167,7 +165,7 @@ put u = mkCmd $ U.update u
---- |
---- import IMTClient as C
---- postAnnuaire "Annuaire IMT" (\n -> (maybe "" identity (C.prenom n)) <> " " <> (maybe "" identity (C.nom n))) (take 30 annuaire)
--mkAnnuaire :: ToJSON a => Name -> (a -> Text) -> [a] -> Cmd NewNode
--mkAnnuaire :: ToJSON a => Name -> (a -> Text) -> [a] -> Cmd err NewNode
--mkAnnuaire name title ns = do
-- pid <- lastMay <$> home
-- let pid' = case lastMay pid of
......@@ -185,6 +183,3 @@ put u = mkCmd $ U.update u
-- let myCorpus' = Prelude.filter (\n -> T.length (maybe "" identity (hyperdataDocument_title n)) > 30) myCorpus
-- corporaOf :: Username -> IO [Corpus]
runCmd' :: Cmd a -> IO a
runCmd' f = connectGargandb "gargantext.ini" >>= \c -> runCmd c f
src/Gargantext/Database/Cooc.hs
View file @ b13b85bf
......@@ -13,26 +13,24 @@ Portability : POSIX
--{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Cooc where
import Control.Monad ((>>=))
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.SqlQQ
import Gargantext.Prelude
import Gargantext (connectGargandb)
import Gargantext.Database.Utils (Cmd, runCmdDevNoErr, runPGSQuery)
type CorpusId = Int
type MainListId = Int
type GroupListId = Int
coocTest :: IO [(Int, Int, Int)]
coocTest = connectGargandb "gargantext.ini"
>>= \conn -> dBcooc conn 421968 446602 446599
coocTest = runCmdDevNoErr $ dBcooc 421968 446602 446599
dBcooc :: Connection -> CorpusId -> MainListId -> GroupListId -> IO [(Int, Int, Int)]
dBcooc conn corpus mainList groupList = query conn [sql|
dBcooc :: CorpusId -> MainListId -> GroupListId -> Cmd err [(Int, Int, Int)]
dBcooc corpus mainList groupList = runPGSQuery [sql|
set work_mem='1GB';
--EXPLAIN ANALYZE
......
src/Gargantext/Database/Facet.hs
View file @ b13b85bf
......@@ -21,6 +21,7 @@ Portability : POSIX
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
------------------------------------------------------------------------
module Gargantext.Database.Facet
......@@ -37,7 +38,6 @@ import Data.Swagger
import Data.Text (Text)
import Data.Time (UTCTime)
import Data.Time.Segment (jour)
import Database.PostgreSQL.Simple (Connection)
import GHC.Generics (Generic)
import Gargantext.Core.Types
import Gargantext.Core.Utils.Prefix (unPrefix)
......@@ -204,8 +204,8 @@ instance Arbitrary OrderBy
arbitrary = elements [minBound..maxBound]
runViewAuthorsDoc :: Connection -> ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
runViewAuthorsDoc c cId t o l order = runQuery c (filterWith o l order $ viewAuthorsDoc cId t ntId)
runViewAuthorsDoc :: ContactId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
runViewAuthorsDoc cId t o l order = runOpaQuery $ filterWith o l order $ viewAuthorsDoc cId t ntId
where
ntId = NodeDocument
......@@ -244,13 +244,9 @@ queryAuthorsDoc = leftJoin5 queryNodeTable queryNodeNgramTable queryNgramsTable
------------------------------------------------------------------------
runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd [FacetDoc]
runViewDocuments cId t o l order = mkCmd $ \c -> runViewDocuments' c cId t o l order
-- | TODO use only Cmd with Reader and delete function below
runViewDocuments' :: Connection -> CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
runViewDocuments' c cId t o l order = runQuery c ( filterWith o l order
$ viewDocuments cId t ntId)
runViewDocuments :: CorpusId -> Trash -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
runViewDocuments cId t o l order =
runOpaQuery $ filterWith o l order $ viewDocuments cId t ntId
where
ntId = nodeTypeId NodeDocument
......
src/Gargantext/Database/Flow.hs
View file @ b13b85bf
This diff is collapsed.
src/Gargantext/Database/Flow/Pairing.hs
View file @ b13b85bf
......@@ -9,9 +9,10 @@ Portability : POSIX
-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
-- {-# LANGUAGE Arrows #-}
module Gargantext.Database.Flow.Pairing
......@@ -19,7 +20,6 @@ module Gargantext.Database.Flow.Pairing
--import Debug.Trace (trace)
import Control.Lens (_Just,view)
import Database.PostgreSQL.Simple (Connection, query)
import Database.PostgreSQL.Simple.SqlQQ (sql)
-- import Opaleye
-- import Opaleye.Aggregate
......@@ -36,27 +36,26 @@ import Gargantext.Database.Schema.Ngrams -- (NgramsType(..))
--import Gargantext.Database.Types.Node -- (Hyperdata(..))
import Gargantext.Database.Node.Contact
import Gargantext.Database.Flow.Utils
import Gargantext.Database.Utils (Cmd, mkCmd)
import Gargantext.Database.Utils (Cmd, runPGSQuery)
import Gargantext.Database.Node.Children
import Gargantext.Core.Types.Main
import Gargantext.Core.Types (NodeType(..))
import Gargantext.Database.Bashql (runCmd')
-- TODO mv this type in Types Main
type Terms = Text
-- | TODO : add paring policy as parameter
pairing :: AnnuaireId -> CorpusId -> IO Int
pairing :: AnnuaireId -> CorpusId -> Cmd err Int
pairing aId cId = do
contacts' <- runCmd' $ getContacts aId (Just NodeContact)
contacts' <- getContacts aId (Just NodeContact)
let contactsMap = pairingPolicyToMap toLower $ toMaps extractNgramsT contacts'
ngramsMap' <- runCmd' $ getNgramsTindexed cId Authors
ngramsMap' <- getNgramsTindexed cId Authors
let ngramsMap = pairingPolicyToMap lastName ngramsMap'
let indexedNgrams = pairMaps contactsMap ngramsMap
runCmd' $ insertToNodeNgrams indexedNgrams
insertToNodeNgrams indexedNgrams
-- TODO add List
lastName :: Terms -> Terms
......@@ -92,13 +91,13 @@ pairMaps m1 m2 = DM.fromList $ catMaybes $ map (\(k,n) -> (,) <$> lookup' k m2 <
-----------------------------------------------------------------------
getNgramsTindexed:: CorpusId -> NgramsType -> Cmd (Map (NgramsT Ngrams) NgramsId)
getNgramsTindexed corpusId ngramsType' = mkCmd $ \c -> fromList
getNgramsTindexed:: CorpusId -> NgramsType -> Cmd err (Map (NgramsT Ngrams) NgramsId)
getNgramsTindexed corpusId ngramsType' = fromList
<$> map (\(ngramsId',t,n) -> (NgramsT ngramsType' (Ngrams t n),ngramsId'))
<$> selectNgramsTindexed c corpusId ngramsType'
<$> selectNgramsTindexed corpusId ngramsType'
selectNgramsTindexed :: Connection -> CorpusId -> NgramsType -> IO [(NgramsId, Terms, Int)]
selectNgramsTindexed c corpusId ngramsType'' = query c selectQuery (corpusId, ngramsTypeId ngramsType'')
selectNgramsTindexed :: CorpusId -> NgramsType -> Cmd err [(NgramsId, Terms, Int)]
selectNgramsTindexed corpusId ngramsType'' = runPGSQuery selectQuery (corpusId, ngramsTypeId ngramsType'')
where
selectQuery = [sql| SELECT n.id,n.terms,n.n from ngrams n
JOIN nodes_ngrams occ ON occ.ngram_id = n.id
......
src/Gargantext/Database/Flow/Utils.hs
View file @ b13b85bf
......@@ -11,6 +11,7 @@ Portability : POSIX
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Flow.Utils
where
......@@ -53,11 +54,11 @@ data DocumentIdWithNgrams a =
} deriving (Show)
insertToNodeNgrams :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd Int
insertToNodeNgrams :: Map (NgramsT NgramsIndexed) (Map NodeId Int) -> Cmd err Int
insertToNodeNgrams m = insertNodeNgrams [ NodeNgram Nothing nId ((_ngramsId . _ngramsT ) ng)
(fromIntegral n) ((ngramsTypeId . _ngramsType) ng)
| (ng, nId2int) <- DM.toList m
, (nId, n) <- DM.toList nId2int
| (ng, nId2int) <- DM.toList m
, (nId, n) <- DM.toList nId2int
]
src/Gargantext/Database/Node/Children.hs
View file @ b13b85bf
......@@ -14,10 +14,10 @@ Portability : POSIX
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Node.Children where
import Database.PostgreSQL.Simple (Connection)
import Opaleye
import Gargantext.Core.Types
import Gargantext.Database.Schema.Node
......@@ -29,12 +29,12 @@ import Gargantext.Database.Node.Contact (HyperdataContact)
import Control.Arrow (returnA)
-- | TODO: use getChildren with Proxy ?
getContacts :: ParentId -> Maybe NodeType -> Cmd [Node HyperdataContact]
getContacts pId maybeNodeType = mkCmd $ \c -> runQuery c $ selectChildren pId maybeNodeType
getContacts :: ParentId -> Maybe NodeType -> Cmd err [Node HyperdataContact]
getContacts pId maybeNodeType = runOpaQuery $ selectChildren pId maybeNodeType
getChildren :: JSONB a => Connection -> ParentId -> proxy a -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> IO [Node a]
getChildren c pId _ maybeNodeType maybeOffset maybeLimit = runQuery c
getChildren :: JSONB a => ParentId -> proxy a -> Maybe NodeType -> Maybe Offset -> Maybe Limit -> Cmd err [Node a]
getChildren pId _ maybeNodeType maybeOffset maybeLimit = runOpaQuery
$ limit' maybeLimit $ offset' maybeOffset
$ orderBy (asc _node_id)
$ selectChildren pId maybeNodeType
......
src/Gargantext/Database/Node/Document/Add.hs
View file @ b13b85bf
......@@ -17,6 +17,7 @@ Add Documents/Contact to a Corpus/Annuaire.
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
------------------------------------------------------------------------
module Gargantext.Database.Node.Document.Add where
......@@ -24,7 +25,7 @@ module Gargantext.Database.Node.Document.Add where
import Data.ByteString.Internal (ByteString)
import Data.Typeable (Typeable)
import Database.PostgreSQL.Simple (Query, formatQuery, query, Only(..))
import Database.PostgreSQL.Simple (Query, Only(..))
import Database.PostgreSQL.Simple.SqlQQ
import Database.PostgreSQL.Simple.ToField (toField)
import Database.PostgreSQL.Simple.ToRow (ToRow(..))
......@@ -32,7 +33,7 @@ import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Data.Text (Text)
import Gargantext.Database.Utils (mkCmd, Cmd(..))
import Gargantext.Database.Utils (Cmd, runPGSQuery, formatPGSQuery)
import Gargantext.Database.Types.Node
import Gargantext.Prelude
......@@ -41,14 +42,14 @@ import GHC.Generics (Generic)
type ParentId = Int
add :: ParentId -> [NodeId] -> Cmd [Only Int]
add pId ns = mkCmd $ \c -> query c queryAdd (Only $ Values fields inputData)
add :: ParentId -> [NodeId] -> Cmd err [Only Int]
add pId ns = runPGSQuery queryAdd (Only $ Values fields inputData)
where
fields = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
inputData = prepare pId ns
add_debug :: ParentId -> [NodeId] -> Cmd ByteString
add_debug pId ns = mkCmd $ \c -> formatQuery c queryAdd (Only $ Values fields inputData)
add_debug :: ParentId -> [NodeId] -> Cmd err ByteString
add_debug pId ns = formatPGSQuery queryAdd (Only $ Values fields inputData)
where
fields = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
inputData = prepare pId ns
......
src/Gargantext/Database/Node/Document/Insert.hs
View file @ b13b85bf
......@@ -44,8 +44,7 @@ the concatenation of the parameters defined by @hashParameters@.
> -- * Example
> insertTest :: FromRow r => CorpusId -> [Node HyperdataDocument] -> IO [r]
> insertTest :: IO [ReturnId]
> insertTest = connectGargandb "gargantext.ini"
> >>= \conn -> insertDocuments conn 1 452162 hyperdataDocuments
> insertTest = runCmdDev $ insertDocuments 1 452162 hyperdataDocuments
-}
------------------------------------------------------------------------
......@@ -55,6 +54,7 @@ the concatenation of the parameters defined by @hashParameters@.
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
------------------------------------------------------------------------
module Gargantext.Database.Node.Document.Insert where
......@@ -66,7 +66,7 @@ import Data.Aeson (toJSON, Value)
import Data.Maybe (maybe)
import Data.Text (Text)
import Data.Typeable (Typeable)
import Database.PostgreSQL.Simple (FromRow, Query, query, Only(..))
import Database.PostgreSQL.Simple (FromRow, Query, Only(..))
import Database.PostgreSQL.Simple.FromRow (fromRow, field)
import Database.PostgreSQL.Simple.SqlQQ
import Database.PostgreSQL.Simple.ToField (toField)
......@@ -74,7 +74,7 @@ import Database.PostgreSQL.Simple.ToRow (ToRow(..))
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import GHC.Generics (Generic)
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Utils (mkCmd, Cmd(..))
import Gargantext.Database.Utils (Cmd, runPGSQuery)
import Gargantext.Database.Node.Contact -- (HyperdataContact(..), ContactWho(..))
import Gargantext.Database.Types.Node
import Gargantext.Prelude
......@@ -113,8 +113,9 @@ import Database.PostgreSQL.Simple (formatQuery)
data ToDbData = ToDbDocument HyperdataDocument | ToDbContact HyperdataContact
insertDocuments :: UserId -> ParentId -> NodeType -> [ToDbData] -> Cmd [ReturnId]
insertDocuments uId pId nodeType hs = mkCmd $ \c -> query c queryInsert (Only $ Values fields $ prepare uId pId nodeType hs)
insertDocuments :: UserId -> ParentId -> NodeType -> [ToDbData] -> Cmd err [ReturnId]
insertDocuments uId pId nodeType =
runPGSQuery queryInsert . Only . Values fields . prepare uId pId nodeType
where
fields = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
......@@ -123,7 +124,7 @@ insertDocuments uId pId nodeType hs = mkCmd $ \c -> query c queryInsert (Only $
-- to print rendered query (Debug purpose) use @formatQuery@ function.
{-
insertDocuments_Debug :: (Hyperdata a, ToJSON a, ToRow a) => UserId -> ParentId -> [a] -> Cmd ByteString
insertDocuments_Debug uId pId hs = mkCmd $ \conn -> formatQuery conn queryInsert (Only $ Values fields inputData)
insertDocuments_Debug uId pId hs = formatPGSQuery queryInsert (Only $ Values fields inputData)
where
fields = map (\t-> QualifiedIdentifier Nothing t) inputSqlTypes
inputData = prepare uId pId hs
......
src/Gargantext/Database/Node/Update.hs
View file @ b13b85bf
......@@ -10,8 +10,9 @@ Portability : POSIX
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Node.Update (Update(..), update) where
......@@ -21,10 +22,11 @@ import qualified Data.Text as DT
import Database.PostgreSQL.Simple
import Gargantext.Prelude
import Gargantext.Database.Utils
-- import Data.ByteString
--rename :: Connection -> NodeId -> Text -> IO ByteString
--rename conn nodeId name = formatQuery conn "UPDATE nodes SET name=? where id=?" (name,nodeId)
--rename :: NodeId -> Text -> IO ByteString
--rename nodeId name = formatPGSQuery "UPDATE nodes SET name=? where id=?" (name,nodeId)
------------------------------------------------------------------------
type NodeId = Int
type Name = Text
......@@ -41,10 +43,10 @@ data Update = Rename NodeId Name
unOnly :: Only a -> a
unOnly (Only a) = a
update :: Update -> Connection -> IO [Int]
update (Rename nId name) conn = map unOnly <$> query conn "UPDATE nodes SET name=? where id=? returning id"
update :: Update -> Cmd err [Int]
update (Rename nId name) = map unOnly <$> runPGSQuery "UPDATE nodes SET name=? where id=? returning id"
(DT.take 255 name,nId)
update (Move nId pId) conn = map unOnly <$> query conn "UPDATE nodes SET parent_id= ? where id=? returning id"
update (Move nId pId) = map unOnly <$> runPGSQuery "UPDATE nodes SET parent_id= ? where id=? returning id"
(pId, nId)
src/Gargantext/Database/Root.hs
View file @ b13b85bf
......@@ -21,12 +21,12 @@ Portability : POSIX
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Root where
import Database.PostgreSQL.Simple (Connection)
import Opaleye (restrict, (.==), Query, runQuery)
import Opaleye (restrict, (.==), Query)
import Opaleye.PGTypes (pgStrictText, pgInt4)
import Control.Arrow (returnA)
import Gargantext.Prelude
......@@ -36,13 +36,10 @@ import Gargantext.Database.Schema.Node (queryNodeTable)
import Gargantext.Database.Schema.User (queryUserTable, UserPoly(..))
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Core.Types.Individu (Username)
import Gargantext.Database.Utils (Cmd(..), mkCmd)
import Gargantext.Database.Utils (Cmd, runOpaQuery)
getRootCmd :: Username -> Cmd [Node HyperdataUser]
getRootCmd u = mkCmd $ \c -> getRoot u c
getRoot :: Username -> Connection -> IO [Node HyperdataUser]
getRoot uname conn = runQuery conn (selectRoot uname)
getRoot :: Username -> Cmd err [Node HyperdataUser]
getRoot = runOpaQuery . selectRoot
selectRoot :: Username -> Query NodeRead
selectRoot username = proc () -> do
......
src/Gargantext/Database/Schema/Ngrams.hs
View file @ b13b85bf
......@@ -19,6 +19,7 @@ Ngrams connection to the Database.
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.Ngrams where
......@@ -43,12 +44,12 @@ import Gargantext.Database.Config (nodeTypeId,userMaster)
import Gargantext.Database.Root (getRoot)
import Gargantext.Database.Types.Node (NodeType)
import Gargantext.Database.Schema.Node (getListsWithParentId, getCorporaWithParentId)
import Gargantext.Database.Utils (mkCmd, Cmd(..))
import Gargantext.Database.Utils (Cmd, runPGSQuery, runOpaQuery, formatPGSQuery)
import Gargantext.Prelude
import Opaleye
import Prelude (Enum, Bounded, minBound, maxBound)
import qualified Data.Set as DS
import qualified Database.PostgreSQL.Simple as DPS
import qualified Database.PostgreSQL.Simple as PGS
--{-
data NgramsPoly id terms n = NgramsDb { ngrams_id :: id
......@@ -85,8 +86,8 @@ ngramsTable = Table "ngrams" (pNgramsDb NgramsDb { ngrams_id = optional "id"
queryNgramsTable :: Query NgramsRead
queryNgramsTable = queryTable ngramsTable
dbGetNgramsDb :: DPS.Connection -> IO [NgramsDb]
dbGetNgramsDb conn = runQuery conn queryNgramsTable
dbGetNgramsDb :: Cmd err [NgramsDb]
dbGetNgramsDb = runOpaQuery queryNgramsTable
--}
-- | Main Ngrams Types
......@@ -118,7 +119,7 @@ data Ngrams = Ngrams { _ngramsTerms :: Text
} deriving (Generic, Show, Eq, Ord)
makeLenses ''Ngrams
instance DPS.ToRow Ngrams where
instance PGS.ToRow Ngrams where
toRow (Ngrams t s) = [toField t, toField s]
text2ngrams :: Text -> Ngrams
......@@ -148,7 +149,7 @@ data NgramIds =
, ngramTerms :: Text
} deriving (Show, Generic, Eq, Ord)
instance DPS.FromRow NgramIds where
instance PGS.FromRow NgramIds where
fromRow = NgramIds <$> field <*> field
----------------------
......@@ -160,21 +161,21 @@ indexNgramsT m ngrId = indexNgramsTWith f ngrId
indexNgramsTWith :: (NgramsTerms -> NgramsId) -> NgramsT Ngrams-> NgramsT NgramsIndexed
indexNgramsTWith f (NgramsT t n) = NgramsT t (NgramsIndexed n ((f . _ngramsTerms) n))
insertNgrams :: [Ngrams] -> Cmd (Map NgramsTerms NgramsId)
insertNgrams :: [Ngrams] -> Cmd err (Map NgramsTerms NgramsId)
insertNgrams ns = fromList <$> map (\(NgramIds i t) -> (t, i)) <$> (insertNgrams' ns)
insertNgrams' :: [Ngrams] -> Cmd [NgramIds]
insertNgrams' ns = mkCmd $ \conn -> DPS.query conn queryInsertNgrams (DPS.Only $ Values fields ns)
insertNgrams' :: [Ngrams] -> Cmd err [NgramIds]
insertNgrams' ns = runPGSQuery queryInsertNgrams (PGS.Only $ Values fields ns)
where
fields = map (\t -> QualifiedIdentifier Nothing t) ["text", "int4"]
insertNgrams_Debug :: [(NgramsTerms, Size)] -> Cmd ByteString
insertNgrams_Debug ns = mkCmd $ \conn -> DPS.formatQuery conn queryInsertNgrams (DPS.Only $ Values fields ns)
insertNgrams_Debug :: [(NgramsTerms, Size)] -> Cmd err ByteString
insertNgrams_Debug ns = formatPGSQuery queryInsertNgrams (PGS.Only $ Values fields ns)
where
fields = map (\t -> QualifiedIdentifier Nothing t) ["text", "int4"]
----------------------
queryInsertNgrams :: DPS.Query
queryInsertNgrams :: PGS.Query
queryInsertNgrams = [sql|
WITH input_rows(terms,n) AS (?)
, ins AS (
......@@ -197,26 +198,25 @@ queryInsertNgrams = [sql|
-- TODO: the way we are getting main Master Corpus and List ID is not clean
-- TODO: if ids are not present -> create
-- TODO: Global Env State Monad to keep in memory the ids without retrieving it each time
getNgramsTableDb :: DPS.Connection
-> NodeType -> NgramsType
-> NgramsTableParamUser
-> Limit -> Offset
-> IO ([NgramsTableData], MapToParent, MapToChildren)
getNgramsTableDb c nt ngrt ntp@(NgramsTableParam listIdUser _) limit_ offset_ = do
getNgramsTableDb :: NodeType -> NgramsType
-> NgramsTableParamUser
-> Limit -> Offset
-> Cmd err ([NgramsTableData], MapToParent, MapToChildren)
getNgramsTableDb nt ngrt ntp@(NgramsTableParam listIdUser _) limit_ offset_ = do
maybeRoot <- head <$> getRoot userMaster c
maybeRoot <- head <$> getRoot userMaster
let path = "Garg.Db.Ngrams.getTableNgrams: "
let masterRootId = maybe (panic $ path <> "no userMaster Tree") (view node_id) maybeRoot
-- let errMess = panic "Error"
corpusMasterId <- maybe (panic "error master corpus") (view node_id) <$> head <$> getCorporaWithParentId c masterRootId
corpusMasterId <- maybe (panic "error master corpus") (view node_id) <$> head <$> getCorporaWithParentId masterRootId
listMasterId <- maybe (panic "error master list") (view node_id) <$> head <$> getListsWithParentId c corpusMasterId
listMasterId <- maybe (panic "error master list") (view node_id) <$> head <$> getListsWithParentId corpusMasterId
ngramsTableData <- getNgramsTableData c nt ngrt ntp (NgramsTableParam listMasterId corpusMasterId) limit_ offset_
ngramsTableData <- getNgramsTableData nt ngrt ntp (NgramsTableParam listMasterId corpusMasterId) limit_ offset_
(mapToParent,mapToChildren) <- getNgramsGroup c listIdUser listMasterId
(mapToParent,mapToChildren) <- getNgramsGroup listIdUser listMasterId
pure (ngramsTableData, mapToParent,mapToChildren)
......@@ -234,15 +234,14 @@ data NgramsTableData = NgramsTableData { _ntd_ngrams :: Text
, _ntd_weight :: Double
} deriving (Show)
getNgramsTableData :: DPS.Connection
-> NodeType -> NgramsType
getNgramsTableData :: NodeType -> NgramsType
-> NgramsTableParamUser -> NgramsTableParamMaster
-> Limit -> Offset
-> IO [NgramsTableData]
getNgramsTableData conn nodeT ngrmT (NgramsTableParam ul uc) (NgramsTableParam ml mc) limit_ offset_ =
-> Cmd err [NgramsTableData]
getNgramsTableData nodeT ngrmT (NgramsTableParam ul uc) (NgramsTableParam ml mc) limit_ offset_ =
trace ("Ngrams table params" <> show params) <$>
map (\(t,n,nt,w) -> NgramsTableData t n (fromListTypeId nt) w) <$>
DPS.query conn querySelectTableNgrams params
runPGSQuery querySelectTableNgrams params
where
nodeTId = nodeTypeId nodeT
ngrmTId = ngramsTypeId ngrmT
......@@ -251,7 +250,7 @@ getNgramsTableData conn nodeT ngrmT (NgramsTableParam ul uc) (NgramsTableParam m
querySelectTableNgrams :: DPS.Query
querySelectTableNgrams :: PGS.Query
querySelectTableNgrams = [sql|
WITH tableUser AS (
......@@ -296,20 +295,14 @@ type ListIdMaster = Int
type MapToChildren = Map Text (Set Text)
type MapToParent = Map Text Text
getNgramsGroup :: DPS.Connection -> ListIdUser -> ListIdMaster -> IO (MapToParent, MapToChildren)
getNgramsGroup conn lu lm = do
groups <- getNgramsGroup' conn lu lm
getNgramsGroup :: ListIdUser -> ListIdMaster -> Cmd err (MapToParent, MapToChildren)
getNgramsGroup lu lm = do
groups <- runPGSQuery querySelectNgramsGroup (lu,lm)
let mapChildren = fromListWith (<>) $ map (\(a,b) -> (a, DS.singleton b)) groups
let mapParent = fromListWith (<>) $ map (\(a,b) -> (b, a)) groups
pure (mapParent, mapChildren)
getNgramsGroup' :: DPS.Connection -> ListIdUser -> ListIdMaster -> IO [(Text,Text)]
getNgramsGroup' conn lu lm = DPS.query conn querySelectNgramsGroup (lu,lm)
getNgramsGroup'' :: ListIdUser -> ListIdMaster -> Cmd [(Text, Text)]
getNgramsGroup'' lu lm = mkCmd $ \conn -> DPS.query conn querySelectNgramsGroup (lu,lm)
querySelectNgramsGroup :: DPS.Query
querySelectNgramsGroup :: PGS.Query
querySelectNgramsGroup = [sql|
WITH groupUser AS (
SELECT n1.terms AS t1, n2.terms AS t2 FROM nodes_ngrams_ngrams nnn
......
src/Gargantext/Database/Schema/Node.hs
View file @ b13b85bf
This diff is collapsed.
src/Gargantext/Database/Schema/NodeNgram.hs
View file @ b13b85bf
......@@ -23,6 +23,7 @@ if Node is a List then it is listing (either Stop, Candidate or Map)
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
......@@ -35,10 +36,10 @@ import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Gargantext.Core.Types.Main (ListId, ListTypeId)
import Gargantext.Database.Utils (mkCmd, Cmd(..))
import Gargantext.Database.Utils (mkCmd, Cmd, runPGSQuery)
import Gargantext.Prelude
import Opaleye
import qualified Database.PostgreSQL.Simple as PGS (Connection, query, Only(..))
import qualified Database.PostgreSQL.Simple as PGS (Only(..))
-- | TODO : remove id
data NodeNgramPoly id node_id ngram_id weight ngrams_type
......@@ -94,14 +95,14 @@ nodeNgramTable = Table "nodes_ngrams"
queryNodeNgramTable :: Query NodeNgramRead
queryNodeNgramTable = queryTable nodeNgramTable
insertNodeNgrams :: [NodeNgram] -> Cmd Int
insertNodeNgrams :: [NodeNgram] -> Cmd err Int
insertNodeNgrams = insertNodeNgramW
. map (\(NodeNgram _ n g w t) ->
NodeNgram Nothing (pgInt4 n) (pgInt4 g)
(pgDouble w) (pgInt4 t)
)
insertNodeNgramW :: [NodeNgramWrite] -> Cmd Int
insertNodeNgramW :: [NodeNgramWrite] -> Cmd err Int
insertNodeNgramW nns =
mkCmd $ \c -> fromIntegral <$> runInsert_ c insertNothing
where
......@@ -113,8 +114,8 @@ insertNodeNgramW nns =
type NgramsText = Text
updateNodeNgrams :: PGS.Connection -> [(ListId, NgramsText, ListTypeId)] -> IO [PGS.Only Int]
updateNodeNgrams c input = PGS.query c updateQuery (PGS.Only $ Values fields $ input)
updateNodeNgrams :: [(ListId, NgramsText, ListTypeId)] -> Cmd err [PGS.Only Int]
updateNodeNgrams input = runPGSQuery updateQuery (PGS.Only $ Values fields $ input)
where
fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","text","int4"]
updateQuery = [sql| UPDATE nodes_ngrams as old SET
......
src/Gargantext/Database/Schema/NodeNgramsNgrams.hs
View file @ b13b85bf
......@@ -25,22 +25,25 @@ Next Step benchmark:
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.Database.Schema.NodeNgramsNgrams
where
import Control.Lens (view)
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import Control.Monad.IO.Class (liftIO)
import Data.Text (Text)
import Data.Maybe (Maybe)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Gargantext.Database.Utils (mkCmd, Cmd(..))
import Gargantext.Database.Utils (Cmd, runOpaQuery, runPGSQuery, connection)
import Gargantext.Prelude
import Opaleye
import qualified Database.PostgreSQL.Simple as DPS
import qualified Database.PostgreSQL.Simple as PGS
data NodeNgramsNgramsPoly node_id ngram1_id ngram2_id weight =
NodeNgramsNgrams { _nng_NodeId :: node_id
......@@ -90,8 +93,8 @@ queryNodeNgramsNgramsTable = queryTable nodeNgramsNgramsTable
-- | Select NodeNgramsNgrams
-- TODO not optimized (get all ngrams without filters)
nodeNgramsNgrams :: DPS.Connection -> IO [NodeNgramsNgrams]
nodeNgramsNgrams conn = runQuery conn queryNodeNgramsNgramsTable
nodeNgramsNgrams :: Cmd err [NodeNgramsNgrams]
nodeNgramsNgrams = runOpaQuery queryNodeNgramsNgramsTable
instance QueryRunnerColumnDefault PGInt4 (Maybe Int) where
queryRunnerColumnDefault = fieldQueryRunnerColumn
......@@ -101,7 +104,7 @@ instance QueryRunnerColumnDefault PGFloat8 (Maybe Double) where
-- TODO: Add option on conflict
insertNodeNgramsNgramsNew :: [NodeNgramsNgrams] -> Cmd Int
insertNodeNgramsNgramsNew :: [NodeNgramsNgrams] -> Cmd err Int
insertNodeNgramsNgramsNew = insertNodeNgramsNgramsW
. map (\(NodeNgramsNgrams n ng1 ng2 maybeWeight) ->
NodeNgramsNgrams (pgInt4 n )
......@@ -110,10 +113,10 @@ insertNodeNgramsNgramsNew = insertNodeNgramsNgramsW
(pgDouble <$> maybeWeight)
)
insertNodeNgramsNgramsW :: [NodeNgramsNgramsWrite] -> Cmd Int
insertNodeNgramsNgramsW ns =
mkCmd $ \c -> fromIntegral
<$> runInsertMany c nodeNgramsNgramsTable ns
insertNodeNgramsNgramsW :: [NodeNgramsNgramsWrite] -> Cmd err Int
insertNodeNgramsNgramsW ns = do
c <- view connection
liftIO $ fromIntegral <$> runInsertMany c nodeNgramsNgramsTable ns
------------------------------------------------------------------------
data Action = Del | Add
......@@ -121,20 +124,17 @@ data Action = Del | Add
type NgramsParent = Text
type NgramsChild = Text
ngramsGroup :: Action -> [(Int, NgramsParent, NgramsChild, Maybe Double)] -> Cmd [Int]
ngramsGroup a ngs = mkCmd $ \c -> ngramsGroup' c a ngs
-- TODO: remove this function (use Reader Monad only)
ngramsGroup' :: DPS.Connection -> Action -> [(Int, NgramsParent, NgramsChild, Maybe Double)] -> IO [Int]
ngramsGroup' c action ngs = runNodeNgramsNgrams c q ngs
ngramsGroup' :: Action -> [(Int, NgramsParent, NgramsChild, Maybe Double)]
-> Cmd err [Int]
ngramsGroup' action ngs = runNodeNgramsNgrams q ngs
where
q = case action of
Del -> queryDelNodeNgramsNgrams
Add -> queryInsertNodeNgramsNgrams
runNodeNgramsNgrams :: DPS.Connection -> DPS.Query -> [(Int, NgramsParent, NgramsChild, Maybe Double)] -> IO [Int]
runNodeNgramsNgrams c q ngs = map (\(DPS.Only a) -> a) <$> DPS.query c q (DPS.Only $ Values fields ngs' )
runNodeNgramsNgrams :: PGS.Query -> [(Int, NgramsParent, NgramsChild, Maybe Double)] -> Cmd err [Int]
runNodeNgramsNgrams q ngs = map (\(PGS.Only a) -> a) <$> runPGSQuery q (PGS.Only $ Values fields ngs' )
where
ngs' = map (\(n,ng1,ng2,w) -> (n,ng1,ng2,maybe 0 identity w)) ngs
fields = map (\t -> QualifiedIdentifier Nothing t)
......@@ -142,7 +142,7 @@ runNodeNgramsNgrams c q ngs = map (\(DPS.Only a) -> a) <$> DPS.query c q (DPS.On
--------------------------------------------------------------------
-- TODO: on conflict update weight
queryInsertNodeNgramsNgrams :: DPS.Query
queryInsertNodeNgramsNgrams :: PGS.Query
queryInsertNodeNgramsNgrams = [sql|
WITH input_rows(nId,ng1,ng2,w) AS (?)
INSERT INTO nodes_ngrams_ngrams (node_id,ngram1_id,ngram2_id,weight)
......@@ -152,7 +152,7 @@ queryInsertNodeNgramsNgrams = [sql|
ON CONFLICT (node_id,ngram1_id,ngram2_id) DO NOTHING -- unique index created here
|]
queryDelNodeNgramsNgrams :: DPS.Query
queryDelNodeNgramsNgrams :: PGS.Query
queryDelNodeNgramsNgrams = [sql|
WITH input(nId,ng1,ng2,w) AS (?)
DELETE FROM nodes_ngrams_ngrams nnn
......
src/Gargantext/Database/Schema/NodeNode.hs
View file @ b13b85bf
......@@ -20,11 +20,12 @@ commentary with @some markup@.
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Schema.NodeNode where
import qualified Database.PostgreSQL.Simple as PGS (Connection, Query, query, Only(..))
import qualified Database.PostgreSQL.Simple as PGS (Query, Only(..))
import Database.PostgreSQL.Simple.Types (Values(..), QualifiedIdentifier(..))
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
......@@ -82,8 +83,8 @@ queryNodeNodeTable = queryTable nodeNodeTable
-- | not optimized (get all ngrams without filters)
nodesNodes :: Cmd [NodeNode]
nodesNodes = mkCmd $ \c -> runQuery c queryNodeNodeTable
nodesNodes :: Cmd err [NodeNode]
nodesNodes = runOpaQuery queryNodeNodeTable
instance QueryRunnerColumnDefault (Nullable PGInt4) Int where
queryRunnerColumnDefault = fieldQueryRunnerColumn
......@@ -97,8 +98,8 @@ instance QueryRunnerColumnDefault PGBool (Maybe Bool) where
------------------------------------------------------------------------
-- | Favorite management
nodeToFavorite :: PGS.Connection -> CorpusId -> DocId -> Bool -> IO [Int]
nodeToFavorite c cId dId b = map (\(PGS.Only a) -> a) <$> PGS.query c favQuery (b,cId,dId)
nodeToFavorite :: CorpusId -> DocId -> Bool -> Cmd err [Int]
nodeToFavorite cId dId b = map (\(PGS.Only a) -> a) <$> runPGSQuery favQuery (b,cId,dId)
where
favQuery :: PGS.Query
favQuery = [sql|UPDATE nodes_nodes SET favorite = ?
......@@ -106,9 +107,9 @@ nodeToFavorite c cId dId b = map (\(PGS.Only a) -> a) <$> PGS.query c favQuery (
RETURNING node2_id;
|]
nodesToFavorite :: PGS.Connection -> [(CorpusId,DocId,Bool)] -> IO [Int]
nodesToFavorite c inputData = map (\(PGS.Only a) -> a)
<$> PGS.query c trashQuery (PGS.Only $ Values fields inputData)
nodesToFavorite :: [(CorpusId,DocId,Bool)] -> Cmd err [Int]
nodesToFavorite inputData = map (\(PGS.Only a) -> a)
<$> runPGSQuery trashQuery (PGS.Only $ Values fields inputData)
where
fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","bool"]
trashQuery :: PGS.Query
......@@ -123,8 +124,8 @@ nodesToFavorite c inputData = map (\(PGS.Only a) -> a)
------------------------------------------------------------------------
------------------------------------------------------------------------
-- | Trash management
nodeToTrash :: PGS.Connection -> CorpusId -> DocId -> Bool -> IO [PGS.Only Int]
nodeToTrash c cId dId b = PGS.query c trashQuery (b,cId,dId)
nodeToTrash :: CorpusId -> DocId -> Bool -> Cmd err [PGS.Only Int]
nodeToTrash cId dId b = runPGSQuery trashQuery (b,cId,dId)
where
trashQuery :: PGS.Query
trashQuery = [sql|UPDATE nodes_nodes SET delete = ?
......@@ -133,9 +134,9 @@ nodeToTrash c cId dId b = PGS.query c trashQuery (b,cId,dId)
|]
-- | Trash Massive
nodesToTrash :: PGS.Connection -> [(CorpusId,DocId,Bool)] -> IO [Int]
nodesToTrash c input = map (\(PGS.Only a) -> a)
<$> PGS.query c trashQuery (PGS.Only $ Values fields input)
nodesToTrash :: [(CorpusId,DocId,Bool)] -> Cmd err [Int]
nodesToTrash input = map (\(PGS.Only a) -> a)
<$> runPGSQuery trashQuery (PGS.Only $ Values fields input)
where
fields = map (\t-> QualifiedIdentifier Nothing t) ["int4","int4","bool"]
trashQuery :: PGS.Query
......@@ -148,8 +149,8 @@ nodesToTrash c input = map (\(PGS.Only a) -> a)
|]
-- | /!\ Really remove nodes in the Corpus or Annuaire
emptyTrash :: PGS.Connection -> CorpusId -> IO [PGS.Only Int]
emptyTrash c cId = PGS.query c delQuery (PGS.Only cId)
emptyTrash :: CorpusId -> Cmd err [PGS.Only Int]
emptyTrash cId = runPGSQuery delQuery (PGS.Only cId)
where
delQuery :: PGS.Query
delQuery = [sql|DELETE from nodes_nodes n
......
src/Gargantext/Database/Schema/NodeNodeNgram.hs
View file @ b13b85bf
......@@ -24,7 +24,7 @@ import Prelude
import Data.Maybe (Maybe)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import qualified Database.PostgreSQL.Simple as PGS
import Gargantext.Database.Utils (Cmd, runOpaQuery)
import Opaleye
......@@ -76,8 +76,8 @@ queryNodeNodeNgramTable :: Query NodeNodeNgramRead
queryNodeNodeNgramTable = queryTable nodeNodeNgramTable
-- | not optimized (get all ngrams without filters)
nodeNodeNgrams :: PGS.Connection -> IO [NodeNodeNgram]
nodeNodeNgrams conn = runQuery conn queryNodeNodeNgramTable
nodeNodeNgrams :: Cmd err [NodeNodeNgram]
nodeNodeNgrams = runOpaQuery queryNodeNodeNgramTable
instance QueryRunnerColumnDefault PGFloat8 (Maybe Double) where
queryRunnerColumnDefault = fieldQueryRunnerColumn
src/Gargantext/Database/Schema/User.hs
View file @ b13b85bf
......@@ -20,6 +20,7 @@ Functions to deal with users, database side.
{-# LANGUAGE Arrows #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Schema.User where
......@@ -156,15 +157,14 @@ instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
queryRunnerColumnDefault = fieldQueryRunnerColumn
users :: Cmd [User]
users = mkCmd $ \conn -> runQuery conn queryUserTable
users :: Cmd err [User]
users = runOpaQuery queryUserTable
usersLight :: Cmd [UserLight]
usersLight = mkCmd $ \conn -> map toUserLight <$> runQuery conn queryUserTable
usersLight :: Cmd err [UserLight]
usersLight = map toUserLight <$> users
getUser :: Username -> Cmd (Maybe UserLight)
getUser u = mkCmd $ \c -> userLightWithUsername u <$> runCmd c usersLight
getUser :: Username -> Cmd err (Maybe UserLight)
getUser u = userLightWithUsername u <$> usersLight
src/Gargantext/Database/TextSearch.hs
View file @ b13b85bf
......@@ -11,6 +11,7 @@ Portability : POSIX
{-# LANGUAGE Arrows #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.TextSearch where
......@@ -21,7 +22,7 @@ import Data.List (intersperse, take, drop)
import Data.String (IsString(..))
import Data.Text (Text, words, unpack, intercalate)
import Data.Time (UTCTime)
import Database.PostgreSQL.Simple -- (Query, Connection)
import Database.PostgreSQL.Simple (Query)
import Database.PostgreSQL.Simple.ToField
import Gargantext.Database.Config (nodeTypeId)
import Gargantext.Database.Types.Node (NodeType(..))
......@@ -33,6 +34,7 @@ import Gargantext.Database.Schema.Ngrams
import Gargantext.Database.Schema.NodeNode
import Gargantext.Database.Schema.NodeNgram
import Gargantext.Database.Queries.Join (leftJoin6)
import Gargantext.Database.Utils (Cmd, runPGSQuery, runOpaQuery)
import Gargantext.Text.Terms.Mono.Stem.En (stemIt)
import Gargantext.Core.Types
import Control.Arrow (returnA)
......@@ -41,8 +43,8 @@ import Opaleye hiding (Query, Order)
------------------------------------------------------------------------
searchInDatabase :: Connection -> ParentId -> Text -> IO [(NodeId, HyperdataDocument)]
searchInDatabase c p t = runQuery c (queryInDatabase p t)
searchInDatabase :: ParentId -> Text -> Cmd err [(NodeId, HyperdataDocument)]
searchInDatabase p t = runOpaQuery (queryInDatabase p t)
-- | Global search query where ParentId is Master Node Corpus Id
queryInDatabase :: ParentId -> Text -> O.Query (Column PGInt4, Column PGJsonb)
......@@ -54,8 +56,8 @@ queryInDatabase _ q = proc () -> do
------------------------------------------------------------------------
-- | todo add limit and offset and order
searchInCorpus :: Connection -> CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetDoc]
searchInCorpus c cId q o l order = runQuery c (filterWith o l order $ queryInCorpus cId q')
searchInCorpus :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetDoc]
searchInCorpus cId q o l order = runOpaQuery (filterWith o l order $ queryInCorpus cId q')
where
q' = intercalate " | " $ map stemIt q
......@@ -77,20 +79,20 @@ joinInCorpus = leftJoin queryNodeSearchTable queryNodeNodeTable cond
type AuthorName = Text
-- | TODO Optim: Offset and Limit in the Query
searchInCorpusWithContacts :: Connection -> CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]]
searchInCorpusWithContacts c cId q o l order = take (maybe 5 identity l) <$> drop (maybe 0 identity o)
searchInCorpusWithContacts :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [FacetPaired Int UTCTime HyperdataDocument Int [Pair Int Text]]
searchInCorpusWithContacts cId q o l order = take (maybe 5 identity l) <$> drop (maybe 0 identity o)
<$> map (\((i,u,h,s), ps) -> FacetPaired i u h s (catMaybes ps))
<$> toList <$> fromListWith (<>)
<$> map (\(FacetPaired i u h s p) -> ((i,u,h,s), [maybePair p]))
<$> searchInCorpusWithContacts' c cId q o l order
<$> searchInCorpusWithContacts' cId q o l order
where
maybePair (Pair Nothing Nothing) = Nothing
maybePair (Pair _ Nothing) = Nothing
maybePair (Pair Nothing _) = Nothing
maybePair (Pair (Just p_id) (Just p_label)) = Just $ Pair p_id p_label
searchInCorpusWithContacts' :: Connection -> CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> IO [(FacetPaired Int UTCTime HyperdataDocument Int (Pair (Maybe Int) (Maybe Text)))]
searchInCorpusWithContacts' c cId q o l order = runQuery c $ queryInCorpusWithContacts cId q' o l order
searchInCorpusWithContacts' :: CorpusId -> [Text] -> Maybe Offset -> Maybe Limit -> Maybe OrderBy -> Cmd err [(FacetPaired Int UTCTime HyperdataDocument Int (Pair (Maybe Int) (Maybe Text)))]
searchInCorpusWithContacts' cId q o l order = runOpaQuery $ queryInCorpusWithContacts cId q' o l order
where
q' = intercalate " | " $ map stemIt q
......@@ -196,13 +198,12 @@ textSearchQuery = "SELECT n.id, n.hyperdata->'publication_year' \
-- | Text Search Function for Master Corpus
-- TODO : text search for user corpus
-- Example:
-- textSearchTest :: ParentId -> TSQuery -> Cmd [(Int, Value, Value, Value, Value, Maybe Int)]
-- textSearchTest pId q = mkCmd $ \c -> textSearch c q pId 5 0 Asc
textSearch :: Connection
-> TSQuery -> ParentId
-- textSearchTest :: ParentId -> TSQuery -> Cmd err [(Int, Value, Value, Value, Value, Maybe Int)]
-- textSearchTest pId q = textSearch q pId 5 0 Asc
textSearch :: TSQuery -> ParentId
-> Limit -> Offset -> Order
-> IO [(Int,Value,Value,Value, Value, Maybe Int)]
textSearch conn q p l o ord = query conn textSearchQuery (q,p,p,typeId,ord,o,l)
-> Cmd err [(Int,Value,Value,Value, Value, Maybe Int)]
textSearch q p l o ord = runPGSQuery textSearchQuery (q,p,p,typeId,ord,o,l)
where
typeId = nodeTypeId NodeDocument
......
src/Gargantext/Database/Tree.hs
View file @ b13b85bf
......@@ -13,13 +13,13 @@ Let a Root Node, return the Tree of the Node as a directed acyclic graph
-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Tree (treeDB, TreeError(..), HasTreeError(..), dbTree, toNodeTree, DbTreeNode) where
import Control.Lens (Prism', (#), (^..), at, each, _Just, to)
import Control.Monad.Error.Class (MonadError(throwError))
import Control.Monad.IO.Class (MonadIO(liftIO))
import Data.Map (Map, fromListWith, lookup)
import Data.Text (Text)
import Database.PostgreSQL.Simple
......@@ -28,11 +28,11 @@ import Database.PostgreSQL.Simple.SqlQQ
import Gargantext.Prelude
import Gargantext.Core.Types.Main (NodeTree(..), Tree(..))
import Gargantext.Database.Config (fromNodeTypeId)
import Gargantext.Database.Utils (Cmd, runPGSQuery)
------------------------------------------------------------------------
-- import Gargantext (connectGargandb)
-- import Control.Monad ((>>=))
-- import Gargantext.Database.Utils (runCmdDev)
-- treeTest :: IO (Tree NodeTree)
-- treeTest = connectGargandb "gargantext.ini" >>= \c -> treeDB c 347474
-- treeTest = runCmdDev $ treeDB 347474
------------------------------------------------------------------------
data TreeError = NoRoot | EmptyRoot | TooManyRoots
......@@ -45,9 +45,8 @@ treeError :: (MonadError e m, HasTreeError e) => TreeError -> m a
treeError te = throwError $ _TreeError # te
-- | Returns the Tree of Nodes in Database
treeDB :: (MonadIO m, MonadError e m, HasTreeError e)
=> Connection -> RootId -> m (Tree NodeTree)
treeDB c r = toTree =<< (toTreeParent <$> liftIO (dbTree c r))
treeDB :: HasTreeError err => RootId -> Cmd err (Tree NodeTree)
treeDB r = toTree =<< (toTreeParent <$> dbTree r)
type RootId = Int
type ParentId = Int
......@@ -83,8 +82,8 @@ data DbTreeNode = DbTreeNode { dt_nodeId :: Int
-- | Main DB Tree function
-- TODO add typenames as parameters
dbTree :: Connection -> RootId -> IO [DbTreeNode]
dbTree conn rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> query conn [sql|
dbTree :: RootId -> Cmd err [DbTreeNode]
dbTree rootId = map (\(nId, tId, pId, n) -> DbTreeNode nId tId pId n) <$> runPGSQuery [sql|
WITH RECURSIVE
-- starting node(s)
starting (id, typename, parent_id, name) AS
......
src/Gargantext/Database/Utils.hs
View file @ b13b85bf
......@@ -11,15 +11,18 @@ Here is a longer description of this module, containing some
commentary with @some markup@.
-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
module Gargantext.Database.Utils where
import Control.Applicative (Applicative)
import Control.Lens (Getter, view)
import Control.Monad.Reader
import Control.Monad.Except
import Data.Aeson (Result(Error,Success), fromJSON, FromJSON)
import Data.Either.Extra (Either(Left, Right))
import Data.Ini (readIniFile, lookupValue)
......@@ -33,36 +36,54 @@ import Database.PostgreSQL.Simple (Connection, connect)
import Database.PostgreSQL.Simple.FromField ( Conversion, ResultError(ConversionFailed), fromField, returnError)
import Database.PostgreSQL.Simple.Internal (Field)
import Gargantext.Prelude
import Opaleye (Query, Unpackspec, showSqlForPostgres)
import Opaleye (Query, Unpackspec, showSqlForPostgres, FromFields, Select, runQuery)
import System.IO (FilePath)
import Text.Read (read)
import qualified Data.ByteString as DB
import qualified Database.PostgreSQL.Simple as PGS
------------------------------------------------------------------------
{- | Reader Monad reinvented here:
class HasConnection env where
connection :: Getter env Connection
newtype Cmd a = Cmd { unCmd :: Connection -> IO a }
instance HasConnection Connection where
connection = identity
instance Monad Cmd where
return a = Cmd $ \_ -> return a
type CmdM env err m =
( MonadReader env m
, HasConnection env
, MonadError err m
, MonadIO m
)
m >>= f = Cmd $ \c -> do
a <- unCmd m c
unCmd (f a) c
-}
type Cmd err a = forall m env. CmdM env err m => m a
-- TODO: ideally there should be very few calls to this functions.
mkCmd :: (Connection -> IO a) -> Cmd err a
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
--type Cmd' a = forall m. (MonadReader env m, HasConnection env, MonadIO m) => m a
-- Use only for dev
runCmdDev :: Show err => Cmd err a -> IO a
runCmdDev f = do
conn <- connectGargandb "gargantext.ini"
either (fail . show) pure =<< runCmd conn f
newtype Cmd a = Cmd (ReaderT Connection IO a)
deriving (Functor, Applicative, Monad, MonadReader Connection, MonadIO)
-- Use only for dev
runCmdDevNoErr :: Cmd () a -> IO a
runCmdDevNoErr = runCmdDev
runCmd :: Connection -> Cmd a -> IO a
runCmd c (Cmd f) = runReaderT f c
runOpaQuery :: Default FromFields fields haskells => Select fields -> Cmd err [haskells]
runOpaQuery q = mkCmd $ \c -> runQuery c q
mkCmd :: (Connection -> IO a) -> Cmd a
mkCmd = Cmd . ReaderT
formatPGSQuery :: PGS.ToRow a => PGS.Query -> a -> Cmd err DB.ByteString
formatPGSQuery q a = mkCmd $ \conn -> PGS.formatQuery conn q a
runPGSQuery :: (PGS.ToRow a, PGS.FromRow b) => PGS.Query -> a -> Cmd err [b]
runPGSQuery q a = mkCmd $ \conn -> PGS.query conn q a
------------------------------------------------------------------------
databaseParameters :: FilePath -> IO PGS.ConnectInfo
......
src/Gargantext/Text/Flow.hs
View file @ b13b85bf
......@@ -17,6 +17,7 @@ From text to viz, all the flow of texts in Gargantext.
module Gargantext.Text.Flow
where
import Control.Monad.Reader
import GHC.IO (FilePath)
import qualified Data.Text as T
import Data.Text.IO (readFile)
......@@ -27,7 +28,7 @@ import qualified Data.Set as DS
import qualified Data.Array.Accelerate as A
import qualified Data.Map.Strict as M
----------------------------------------------
import Gargantext.Database (Connection)
import Database.PostgreSQL.Simple (Connection)
import Gargantext.Database.Schema.Node
import Gargantext.Database.Types.Node
......@@ -86,7 +87,7 @@ textFlow termType workType = do
FullText path -> splitBy (Sentences 5) <$> readFile path
CSV path -> readCsvOn [csv_title, csv_abstract] path
Contexts ctxt -> pure ctxt
DBV3 con corpusId -> catMaybes <$> map (\n -> hyperdataDocumentV3_title (_node_hyperdata n) <> hyperdataDocumentV3_abstract (_node_hyperdata n))<$> getDocumentsV3WithParentId con corpusId
DBV3 con corpusId -> catMaybes <$> map (\n -> hyperdataDocumentV3_title (_node_hyperdata n) <> hyperdataDocumentV3_abstract (_node_hyperdata n))<$> runReaderT (getDocumentsV3WithParentId corpusId) con
_ -> undefined -- TODO Query not supported
textFlow' termType contexts
......
src/Gargantext/Viz/Graph.hs
View file @ b13b85bf
......@@ -18,6 +18,7 @@ module Gargantext.Viz.Graph
------------------------------------------------------------------------
import Control.Lens (makeLenses)
import Control.Monad.IO.Class (MonadIO(liftIO))
import GHC.IO (FilePath)
import GHC.Generics (Generic)
import Data.Aeson.TH (deriveJSON)
......@@ -207,7 +208,7 @@ graphV3ToGraphWithFiles g1 g2 = do
DBL.writeFile g2 (DA.encode $ graphV3ToGraph newGraph)
readGraphFromJson :: FilePath -> IO (Maybe Graph)
readGraphFromJson :: MonadIO m => FilePath -> m (Maybe Graph)
readGraphFromJson fp = do
graph <- DBL.readFile fp
graph <- liftIO $ DBL.readFile fp
pure $ DA.decode graph
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