Skip to content
Projects
Groups
Snippets
Help
Loading...
Help
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
haskell-gargantext
Project
Project
Details
Activity
Releases
Cycle Analytics
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Charts
Issues
0
Issues
0
List
Board
Labels
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Charts
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Charts
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Christian Merten
haskell-gargantext
Commits
d9c87567
Unverified
Commit
d9c87567
authored
Nov 29, 2018
by
Nicolas Pouillard
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
WIP
parent
7408a02c
Changes
6
Hide whitespace changes
Inline
Side-by-side
Showing
6 changed files
with
185 additions
and
113 deletions
+185
-113
Ngrams.hs
src/Gargantext/API/Ngrams.hs
+77
-31
Node.hs
src/Gargantext/API/Node.hs
+7
-0
Ngrams.hs
src/Gargantext/Database/Schema/Ngrams.hs
+11
-11
Node.hs
src/Gargantext/Database/Schema/Node.hs
+64
-66
NodeNgram.hs
src/Gargantext/Database/Schema/NodeNgram.hs
+3
-3
Utils.hs
src/Gargantext/Database/Utils.hs
+23
-2
No files found.
src/Gargantext/API/Ngrams.hs
View file @
d9c87567
...
...
@@ -42,7 +42,8 @@ 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
Data.Aeson
...
...
@@ -183,27 +184,14 @@ 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_"
)
''
N
gramsIdPatch
)
instance
ToSchema
NgramsIdPatch
instance
Arbitrary
NgramsIdPatch
where
arbitrary
=
NgramsIdPatch
<$>
arbitrary
<*>
arbitrary
--
-- TODO:
-- * This should be a Map NgramsId NgramsPatch
-- * Patchs -> Patches
newtype
Ngrams
IdPatchs
=
Ngrams
IdPatchs
{
_nip_ngramsIdPatchs
::
[
NgramsIdPatch
]
}
newtype
Ngrams
TablePatch
=
Ngrams
TablePatch
{
_nip_ngramsIdPatchs
::
Map
NgramsTerm
NgramsPatch
}
deriving
(
Ord
,
Eq
,
Show
,
Generic
,
Arbitrary
)
$
(
deriveJSON
(
unPrefix
"_nip_"
)
''
N
grams
IdPatchs
)
instance
ToSchema
Ngrams
IdPatchs
$
(
deriveJSON
(
unPrefix
"_nip_"
)
''
N
grams
TablePatch
)
instance
ToSchema
Ngrams
TablePatch
------------------------------------------------------------------------
------------------------------------------------------------------------
...
...
@@ -243,6 +231,15 @@ type TableNgramsApiGet = Summary " Table Ngrams API Get"
type
TableNgramsApi
=
Summary
" Table Ngrams API Change"
:>
QueryParam
"list"
ListId
<<<<<<<
HEAD
:>
ReqBody
'[
J
SON
]
NgramsIdPatchsFeed
-- Versioned ...
:>
Put
'[
J
SON
]
NgramsIdPatchsBack
-- Versioned ...
type
NgramsIdPatchsFeed
=
NgramsIdPatchs
type
NgramsIdPatchsBack
=
NgramsIdPatchs
|||||||
parent
of
06
bfb6e
...
WIP
:>
ReqBody
'[
J
SON
]
NgramsIdPatchsFeed
-- Versioned ...
:>
Put
'[
J
SON
]
NgramsIdPatchsBack
-- Versioned ...
...
...
@@ -250,15 +247,52 @@ type NgramsIdPatchsFeed = NgramsIdPatchs
type
NgramsIdPatchsBack
=
NgramsIdPatchs
defaultList
::
Connection
->
CorpusId
->
IO
ListId
defaultList
c
cId
=
view
node_id
<$>
maybe
(
panic
noListFound
)
identity
<$>
head
<$>
getListsWithParentId
c
cId
where
noListFound
=
"Gargantext.API.Ngrams.defaultList: no list found"
=======
:>
ReqBody
'[
J
SON
]
(
Versioned
NgramsTablePatch
)
:>
Put
'[
J
SON
]
(
Versioned
NgramsTablePatch
)
data
NgramError
=
NoListFound
deriving
(
Show
)
class
HasNgramError
e
where
_NgramError
::
Prism'
e
NgramError
instance
HasNgramError
ServantErr
where
_NgramError
=
prism'
mk
(
const
Nothing
)
-- Note a prism
where
mk
NoListFound
=
err404
{
errBody
=
"NgramError: No list found"
}
mk
EmptyRoot
=
err500
{
errBody
=
"Root node should not be empty"
}
mk
TooManyRoots
=
err500
{
errBody
=
"Too many root nodes"
}
ngramError
::
(
MonadError
e
m
,
HasNgramError
e
)
=>
NgramError
->
m
a
ngramError
nne
=
throwError
$
_NgramError
#
nne
defaultList
::
(
MonadError
e
m
,
HasNgramError
e
,
MonadReader
env
m
,
HasConnection
env
)
=>
CorpusId
->
m
ListId
defaultList
cId
=
view
node_id
=<<
maybe
(
ngramError
NoListFound
)
pure
<$>
head
<$>
getListsWithParentId
cId
>>>>>>>
06
bfb6e
...
WIP
{-
toLists :: ListId -> Ngrams
IdPatchs
-> [(ListId, NgramsId, ListTypeId)]
toLists :: ListId -> Ngrams
TablePatch
-> [(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) -> Ngrams
IdPatchs
-> [NodeNgramsNgrams]
toGroups :: ListId -> (NgramsPatch -> Set NgramsId) -> Ngrams
TablePatch
-> [NodeNgramsNgrams]
toGroups lId addOrRem ps = concat $ map (toGroup lId addOrRem) $ _nip_ngramsIdPatchs ps
toGroup :: ListId -> (NgramsPatch -> Set NgramsId) -> NgramsIdPatch -> [NodeNgramsNgrams]
...
...
@@ -268,22 +302,34 @@ 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
::
(
MonadError
e
m
,
HasNgramError
e
,
MonadReader
env
m
,
HasConnection
env
,
MonadIO
m
)
=>
CorpusId
->
Maybe
ListId
->
Versioned
NgramsTablePatch
->
m
(
Versioned
NgramsTablePatch
)
tableNgramsPatch
conn
corpusId
maybeList
(
Versioned
version
patch
)
=
do
when
(
version
/=
1
)
$
ngramError
$
UnsupportedVersion
v
listId
<-
maybe
defaultList
pure
maybeList
{-
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 [])
_ <- ngramsGroup' conn Add $ toGroups listId _np_add_children patch
_ <- ngramsGroup' conn Del $ toGroups listId _np_rem_children patch
_ <- updateNodeNgrams conn (toLists listId patch)
-}
pure
$
Version
1
mempty
-- | TODO Errors management
-- TODO: polymorphic for Annuaire or Corpus or ...
getTableNgrams
::
Connection
->
CorpusId
->
Maybe
TabType
->
Maybe
ListId
->
IO
NgramsTable
-- getTableNgrams :: Connection -> CorpusId -> Maybe TabType -> Maybe ListId -> IO NgramsTable
getTableNgrams
::
Connection
->
CorpusId
->
Handler
TableNgramsApiGet
getTableNgrams
c
cId
maybeTabType
maybeListId
=
do
let
lieu
=
"Garg.API.Ngrams: "
::
Text
let
ngramsType
=
case
maybeTabType
of
...
...
src/Gargantext/API/Node.hs
View file @
d9c87567
...
...
@@ -252,6 +252,13 @@ graphAPI _ _ = do
-- liftIO $ liftIO $ pure $ maybe t identity maybeGraph
-- TODO what do we get about the node? to replace contextText
instance
HasNodeError
ServantErr
where
_NodeError
=
prism'
make
match
where
err
=
err404
{
errBody
=
"NodeError: No list found"
}
make
NoListFound
=
err
match
=
guard
(
==
err
)
$>
NoListFound
-- TODO(orphan): There should be a proper APIError data type with a case TreeError.
instance
HasTreeError
ServantErr
where
_TreeError
=
prism'
mk
(
const
Nothing
)
-- Note a prism
...
...
src/Gargantext/Database/Schema/Ngrams.hs
View file @
d9c87567
...
...
@@ -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
...
...
@@ -44,7 +45,7 @@ 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
(
mkCmd
,
Cmd
(
..
)
,
Cmd
'
)
import
Gargantext.Prelude
import
Opaleye
import
Prelude
(
Enum
,
Bounded
,
minBound
,
maxBound
)
...
...
@@ -198,25 +199,24 @@ 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
->
IO
([
NgramsTableData
],
MapToParent
,
MapToChildren
)
getNgramsTableDb
c
nt
ngrt
ntp
@
(
NgramsTableParam
listIdUser
_
)
=
do
getNgramsTableDb
::
NodeType
->
NgramsType
->
NgramsTableParamUser
->
Cmd'
err
([
NgramsTableData
],
MapToParent
,
MapToChildren
)
getNgramsTableDb
nt
ngrt
ntp
@
(
NgramsTableParam
listIdUser
_
)
=
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
)
ngramsTableData
<-
getNgramsTableData
nt
ngrt
ntp
(
NgramsTableParam
listMasterId
corpusMasterId
)
(
mapToParent
,
mapToChildren
)
<-
getNgramsGroup
c
listIdUser
listMasterId
(
mapToParent
,
mapToChildren
)
<-
getNgramsGroup
listIdUser
listMasterId
pure
(
ngramsTableData
,
mapToParent
,
mapToChildren
)
...
...
src/Gargantext/Database/Schema/Node.hs
View file @
d9c87567
...
...
@@ -20,13 +20,16 @@ Portability : POSIX
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module
Gargantext.Database.Schema.Node
where
import
Control.Arrow
(
returnA
)
import
Control.Lens
(
set
)
import
Control.Lens
(
Prism
'
,
set
,
view
,
(
#
),
(
^?
)
)
import
Control.Lens.TH
(
makeLensesWith
,
abbreviatedFields
)
import
Control.Monad.Error.Class
(
MonadError
(
..
))
import
Control.Monad.IO.Class
(
MonadIO
(
..
))
import
Data.Aeson
import
Data.ByteString
(
ByteString
)
import
Data.Maybe
(
Maybe
(
..
),
fromMaybe
)
...
...
@@ -53,8 +56,26 @@ import qualified Data.ByteString.Lazy as DBL
import
qualified
Data.Profunctor.Product
as
PP
------------------------------------------------------------------------
instance
FromField
HyperdataAny
where
data
NodeError
=
NoListFound
deriving
(
Show
)
class
HasNodeError
e
where
_NodeError
::
Prism'
e
NodeError
nodeError
::
(
MonadError
e
m
,
HasNodeError
e
)
=>
NodeError
->
m
a
nodeError
ne
=
throwError
$
_NodeError
#
ne
catchNodeError
::
(
MonadError
e
m
,
HasNodeError
e
)
=>
m
a
->
(
NodeError
->
m
a
)
->
m
a
catchNodeError
f
g
=
catchError
f
(
\
e
->
maybe
(
throwError
e
)
g
(
e
^?
_NodeError
))
------------------------------------------------------------------------
type
AnnuaireId
=
Int
type
DocId
=
Int
type
TypeId
=
Int
------------------------------------------------------------------------
instance
FromField
HyperdataAny
where
fromField
=
fromField'
instance
FromField
HyperdataCorpus
...
...
@@ -290,11 +311,6 @@ selectNodesWith' parentId maybeNodeType = proc () -> do
returnA
-<
node
--type Cmd' a = forall m. (MonadReader env m, HasConnection env, MonadIO m) => m a
-- deleteNode :: (MonadReader Connection m, MonadIO m) => Int -> m Int
-- deleteNode :: Int -> Cmd' Int
deleteNode
::
Int
->
Cmd
Int
deleteNode
n
=
mkCmd
$
\
conn
->
...
...
@@ -330,8 +346,8 @@ getDocumentsV3WithParentId conn n = runQuery conn $ selectNodesWith' n (Just Nod
getDocumentsWithParentId
::
Connection
->
Int
->
IO
[
Node
HyperdataDocument
]
getDocumentsWithParentId
conn
n
=
runQuery
conn
$
selectNodesWith'
n
(
Just
NodeDocument
)
getListsWithParentId
::
Connection
->
Int
->
IO
[
Node
HyperdataList
]
getListsWithParentId
conn
n
=
runQuery
conn
$
selectNodesWith'
n
(
Just
NodeList
)
getListsWithParentId
::
Int
->
Cmd'
err
[
Node
HyperdataList
]
getListsWithParentId
n
=
runQuery'
$
selectNodesWith'
n
(
Just
NodeList
)
getCorporaWithParentId
::
Connection
->
Int
->
IO
[
Node
HyperdataCorpus
]
getCorporaWithParentId
conn
n
=
runQuery
conn
$
selectNodesWith'
n
(
Just
NodeCorpus
)
...
...
@@ -470,20 +486,21 @@ node2row (Node id tn ud pid nm dt hp) = ((pgInt4 <$> id)
,(
pgStrictJSONB
hp
)
)
------------------------------------------------------------------------
insertNodesR'
::
[
NodeWrite'
]
->
Cmd
[
Int
]
insertNodesR'
ns
=
mkCmd
$
\
c
->
insertNodesR
ns
c
insertNodes
::
[
NodeWrite'
]
->
Cmd'
err
Int64
insertNodes
ns
=
do
conn
<-
view
connection
liftIO
$
runInsertMany
conn
nodeTable'
(
map
node2row
ns
)
insertNodes
::
[
NodeWrite'
]
->
Connection
->
IO
Int64
insertNodes
ns
conn
=
runInsertMany
conn
nodeTable'
(
map
node2row
ns
)
insertNodesR
::
[
NodeWrite'
]
->
Cmd'
err
[
Int
]
insertNodesR
ns
=
do
conn
<-
view
connection
liftIO
$
runInsert_
conn
(
Insert
nodeTable'
(
node2row
<$>
ns
)
(
rReturning
(
\
(
i
,
_
,
_
,
_
,
_
,
_
,
_
)
->
i
))
Nothing
)
insertNodesR
::
[
NodeWrite'
]
->
Connection
->
IO
[
Int
]
insertNodesR
ns
conn
=
runInsertManyReturning
conn
nodeTable'
(
map
node2row
ns
)
(
\
(
i
,
_
,
_
,
_
,
_
,
_
,
_
)
->
i
)
-------------------------
insertNodesWithParent
::
Maybe
ParentId
->
[
NodeWrite'
]
->
Connection
->
IO
Int64
insertNodesWithParent
pid
ns
conn
=
insertNodes
(
map
(
set
node_parentId
pid
)
ns
)
conn
insertNodesWithParent
::
Maybe
ParentId
->
[
NodeWrite'
]
->
Cmd'
err
Int64
insertNodesWithParent
pid
ns
=
insertNodes
(
set
node_parentId
pid
<$>
ns
)
insertNodesWithParentR
::
Maybe
ParentId
->
[
NodeWrite'
]
->
C
onnection
->
IO
[
Int
]
insertNodesWithParentR
pid
ns
conn
=
insertNodesR
(
map
(
set
node_parentId
pid
)
ns
)
conn
insertNodesWithParentR
::
Maybe
ParentId
->
[
NodeWrite'
]
->
C
md'
err
[
Int
]
insertNodesWithParentR
pid
ns
=
insertNodesR
(
set
node_parentId
pid
<$>
ns
)
------------------------------------------------------------------------
-- TODO Hierachy of Nodes
-- post and get same types Node' and update if changes
...
...
@@ -565,72 +582,53 @@ childWith _ _ (Node' _ _ _ _) = panic "This NodeType can not be a c
mk
::
Connection
->
NodeType
->
Maybe
ParentId
->
Text
->
IO
[
Int
]
mk
c
nt
pId
name
=
mk'
c
nt
userId
pId
name
mk
::
NodeType
->
Maybe
ParentId
->
Text
->
Cmd'
err
[
Int
]
mk
nt
pId
name
=
mk'
nt
userId
pId
name
where
userId
=
1
mk'
::
Connection
->
NodeType
->
UserId
->
Maybe
ParentId
->
Text
->
IO
[
Int
]
mk'
c
nt
uId
pId
name
=
map
fromIntegral
<$>
insertNodesWithParentR
pId
[
node
nt
name
hd
pId
uId
]
c
mk'
::
NodeType
->
UserId
->
Maybe
ParentId
->
Text
->
Cmd'
err
[
Int
]
mk'
nt
uId
pId
name
=
map
fromIntegral
<$>
insertNodesWithParentR
pId
[
node
nt
name
hd
pId
uId
]
where
hd
=
HyperdataUser
.
Just
.
pack
$
show
EN
type
Name
=
Text
mk''
::
NodeType
->
Maybe
ParentId
->
UserId
->
Name
->
Cmd
[
Int
]
mk''
NodeUser
Nothing
uId
name
=
mk
Cmd
$
\
c
->
mk'
c
NodeUser
uId
Nothing
name
mk''
::
NodeType
->
Maybe
ParentId
->
UserId
->
Name
->
Cmd
'
err
[
Int
]
mk''
NodeUser
Nothing
uId
name
=
mk
'
NodeUser
uId
Nothing
name
mk''
NodeUser
_
_
_
=
panic
"NodeUser do not have any parent"
mk''
_
Nothing
_
_
=
panic
"NodeType does have a parent"
mk''
nt
pId
uId
name
=
mkCmd
$
\
c
->
mk'
c
nt
uId
pId
name
mk''
nt
pId
uId
name
=
mk'
nt
uId
pId
name
mkRoot
::
Username
->
UserId
->
Cmd
[
Int
]
mkRoot
::
Username
->
UserId
->
Cmd
'
err
[
Int
]
mkRoot
uname
uId
=
case
uId
>
0
of
False
->
panic
"UserId <= 0"
True
->
mk''
NodeUser
Nothing
uId
uname
mkCorpus
::
Maybe
Name
->
Maybe
HyperdataCorpus
->
ParentId
->
UserId
->
Cmd
[
Int
]
mkCorpus
n
h
p
u
=
insertNodesR
'
[
nodeCorpusW
n
h
p
u
]
mkCorpus
::
Maybe
Name
->
Maybe
HyperdataCorpus
->
ParentId
->
UserId
->
Cmd
'
err
[
Int
]
mkCorpus
n
h
p
u
=
insertNodesR
[
nodeCorpusW
n
h
p
u
]
--{-
getOrMkList
::
ParentId
->
UserId
->
Cmd
Int
getOrMkList
pId
uId
=
do
maybeList
<-
defaultListSafe'
pId
case
maybeList
of
Nothing
->
maybe
(
panic
"no list"
)
identity
<$>
headMay
<$>
mkList
pId
uId
Just
x
->
pure
x
defaultListSafe'
::
CorpusId
->
Cmd
(
Maybe
ListId
)
defaultListSafe'
cId
=
mkCmd
$
\
c
->
do
maybeNode
<-
headMay
<$>
getListsWithParentId
c
cId
case
maybeNode
of
Nothing
->
pure
Nothing
(
Just
node
)
->
pure
$
Just
$
_node_id
node
--}
getOrMkList
::
HasNodeError
err
=>
ParentId
->
UserId
->
Cmd'
err
Int
getOrMkList
pId
uId
=
defaultList
pId
`
catchNodeError
`
(
\
NoListFound
->
maybe
(
nodeError
NoListFound
)
pure
.
headMay
=<<
mkList
pId
uId
)
defaultListSafe
::
Connection
->
CorpusId
->
IO
(
Maybe
ListId
)
defaultListSafe
c
cId
=
do
maybeNode
<-
headMay
<$>
getListsWithParentId
c
cId
case
maybeNode
of
Nothing
->
pure
Nothing
(
Just
node
)
->
pure
$
Just
$
_node_id
node
defaultList
::
Connection
->
CorpusId
->
IO
ListId
defaultList
c
cId
=
maybe
(
panic
errMessage
)
identity
<$>
defaultListSafe
c
cId
where
errMessage
=
"Gargantext.API.Ngrams.defaultList: no list found"
defaultList
::
HasNodeError
err
=>
CorpusId
->
Cmd'
err
ListId
defaultList
cId
=
maybe
(
nodeError
NoListFound
)
(
pure
.
view
node_id
)
.
headMay
=<<
getListsWithParentId
cId
mkList
::
ParentId
->
UserId
->
Cmd
[
Int
]
mkList
p
u
=
insertNodesR
'
[
nodeListW
Nothing
Nothing
p
u
]
mkList
::
HasNodeError
err
=>
ParentId
->
UserId
->
Cmd'
err
[
Int
]
mkList
p
u
=
insertNodesR
[
nodeListW
Nothing
Nothing
p
u
]
mkGraph
::
ParentId
->
UserId
->
Cmd
[
Int
]
mkGraph
p
u
=
insertNodesR
'
[
nodeGraphW
Nothing
Nothing
p
u
]
mkGraph
::
ParentId
->
UserId
->
Cmd
'
err
[
Int
]
mkGraph
p
u
=
insertNodesR
[
nodeGraphW
Nothing
Nothing
p
u
]
mkDashboard
::
ParentId
->
UserId
->
Cmd
[
Int
]
mkDashboard
p
u
=
insertNodesR
'
[
nodeDashboardW
Nothing
Nothing
p
u
]
mkDashboard
::
ParentId
->
UserId
->
Cmd
'
err
[
Int
]
mkDashboard
p
u
=
insertNodesR
[
nodeDashboardW
Nothing
Nothing
p
u
]
mkAnnuaire
::
ParentId
->
UserId
->
Cmd
[
Int
]
mkAnnuaire
p
u
=
insertNodesR
'
[
nodeAnnuaireW
Nothing
Nothing
p
u
]
mkAnnuaire
::
ParentId
->
UserId
->
Cmd
'
err
[
Int
]
mkAnnuaire
p
u
=
insertNodesR
[
nodeAnnuaireW
Nothing
Nothing
p
u
]
-- | Default CorpusId Master and ListId Master
src/Gargantext/Database/Schema/NodeNgram.hs
View file @
d9c87567
...
...
@@ -38,7 +38,7 @@ import Gargantext.Core.Types.Main (ListId, ListTypeId)
import
Gargantext.Database.Utils
(
mkCmd
,
Cmd
(
..
))
import
Gargantext.Prelude
import
Opaleye
import
qualified
Database.PostgreSQL.Simple
as
PGS
(
Connection
,
query
,
Only
(
..
))
import
qualified
Database.PostgreSQL.Simple
as
PGS
(
query
,
Only
(
..
))
-- | TODO : remove id
data
NodeNgramPoly
id
node_id
ngram_id
weight
ngrams_type
...
...
@@ -108,8 +108,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
[
PGS
.
Only
Int
]
updateNodeNgrams
input
=
mkCmd
$
\
c
->
PGS
.
query
c
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/Utils.hs
View file @
d9c87567
...
...
@@ -15,11 +15,14 @@ commentary with @some markup@.
{-# 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.Error.Class
import
Data.Aeson
(
Result
(
Error
,
Success
),
fromJSON
,
FromJSON
)
import
Data.Either.Extra
(
Either
(
Left
,
Right
))
import
Data.Ini
(
readIniFile
,
lookupValue
)
...
...
@@ -33,12 +36,31 @@ 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
class
HasConnection
env
where
connection
::
Getter
env
Connection
instance
HasConnection
Connection
where
connection
=
identity
type
Cmd'
err
a
=
forall
m
env
.
(
MonadReader
env
m
,
HasConnection
env
,
MonadError
err
m
,
MonadIO
m
)
=>
m
a
runQuery'
::
Default
FromFields
fields
haskells
=>
Select
fields
->
Cmd'
err
[
haskells
]
runQuery'
q
=
do
c
<-
view
connection
liftIO
$
runQuery
c
q
------------------------------------------------------------------------
{- | Reader Monad reinvented here:
...
...
@@ -60,7 +82,6 @@ runCmd c (Cmd f) = runReaderT f c
mkCmd
::
(
Connection
->
IO
a
)
->
Cmd
a
mkCmd
=
Cmd
.
ReaderT
------------------------------------------------------------------------
databaseParameters
::
FilePath
->
IO
PGS
.
ConnectInfo
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment