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
157
Issues
157
List
Board
Labels
Milestones
Merge Requests
9
Merge Requests
9
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
gargantext
haskell-gargantext
Commits
052f4bf8
Commit
052f4bf8
authored
Aug 21, 2023
by
Alfredo Di Napoli
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Support line number and module in logging via TH
parent
b0cd4cda
Pipeline
#4512
passed with stages
in 11 minutes and 45 seconds
Changes
2
Pipelines
1
Show whitespace changes
Inline
Side-by-side
Showing
2 changed files
with
41 additions
and
9 deletions
+41
-9
New.hs
src/Gargantext/API/Node/Corpus/New.hs
+7
-8
Logging.hs
src/Gargantext/System/Logging.hs
+34
-1
No files found.
src/Gargantext/API/Node/Corpus/New.hs
View file @
052f4bf8
...
...
@@ -21,7 +21,6 @@ module Gargantext.API.Node.Corpus.New
import
Conduit
import
Control.Lens
hiding
(
elements
,
Empty
)
import
Control.Monad
import
Data.Aeson
import
Data.Aeson.TH
(
deriveJSON
)
import
qualified
Data.ByteString.Base64
as
BSB64
...
...
@@ -204,15 +203,15 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
,
_wq_flowListWith
=
flw
})
maybeLimit
jobHandle
=
do
-- TODO ...
logM
DEBUG
$
T
.
pack
$
"[addToCorpusWithQuery]
(cid, dbs) "
<>
show
(
cid
,
dbs
)
logM
DEBUG
$
T
.
pack
$
"[addToCorpusWithQuery]
datafield "
<>
show
datafield
logM
DEBUG
$
T
.
pack
$
"[addToCorpusWithQuery]
flowListWith "
<>
show
flw
$
(
logLocM
)
DEBUG
$
T
.
pack
$
"
(cid, dbs) "
<>
show
(
cid
,
dbs
)
$
(
logLocM
)
DEBUG
$
T
.
pack
$
"
datafield "
<>
show
datafield
$
(
logLocM
)
DEBUG
$
T
.
pack
$
"
flowListWith "
<>
show
flw
addLanguageToCorpus
cid
l
case
datafield
of
Just
Web
->
do
logM
DEBUG
$
T
.
pack
$
"[addToCorpusWithQuery]
processing web request "
<>
show
datafield
$
(
logLocM
)
DEBUG
$
T
.
pack
$
"
processing web request "
<>
show
datafield
markStarted
1
jobHandle
...
...
@@ -227,7 +226,7 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
-- TODO if cid is folder -> create Corpus
-- if cid is corpus -> add to corpus
-- if cid is root -> create corpus in Private
logM
DEBUG
$
T
.
pack
$
"[G.A.N.C.New]
getDataText with query: "
<>
show
q
$
(
logLocM
)
DEBUG
$
T
.
pack
$
"
getDataText with query: "
<>
show
q
let
db
=
database2origin
dbs
mPubmedAPIKey
<-
getUserPubmedAPIKey
user
-- printDebug "[addToCorpusWithQuery] mPubmedAPIKey" mPubmedAPIKey
...
...
@@ -240,8 +239,8 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
markProgress
1
jobHandle
void
$
flowDataText
user
txt
(
Multi
l
)
cid
(
Just
flw
)
jobHandle
-- printDebug "corpus id" cids
corpusId
<-
flowDataText
user
txt
(
Multi
l
)
cid
(
Just
flw
)
jobHandle
$
(
logLocM
)
DEBUG
$
T
.
pack
$
"corpus id "
<>
show
corpusId
-- printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
sendMail
user
-- TODO ...
...
...
src/Gargantext/System/Logging.hs
View file @
052f4bf8
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module
Gargantext.System.Logging
(
...
...
@@ -5,16 +6,19 @@ module Gargantext.System.Logging (
,
HasLogger
(
..
)
,
MonadLogger
(
..
)
,
logM
,
logLocM
,
withLogger
,
withLoggerHoisted
)
where
import
Language.Haskell.TH
hiding
(
Type
)
import
Control.Exception.Lifted
(
bracket
)
import
Control.Monad.IO.Class
import
Control.Monad.Trans.Control
import
Data.Kind
(
Type
)
import
Prelude
import
qualified
Data.Text
as
T
import
qualified
Language.Haskell.TH.Syntax
as
TH
data
LogLevel
=
-- | Debug messages
...
...
@@ -61,6 +65,35 @@ logM level msg = do
logger
<-
getLogger
logTxt
logger
level
msg
-- | Like 'logM', but it automatically adds the file and line number to
-- the output log.
logLocM
::
ExpQ
logLocM
=
[
|
\
level
msg
->
let
loc
=
$
(
getLocTH
)
in
logM
level
(
formatWithLoc
loc
msg
)
|
]
formatWithLoc
::
Loc
->
T
.
Text
->
T
.
Text
formatWithLoc
loc
msg
=
"["
<>
locationToText
<>
"] "
<>
msg
where
locationToText
::
T
.
Text
locationToText
=
T
.
pack
$
(
loc_filename
loc
)
++
':'
:
(
line
loc
)
++
':'
:
(
char
loc
)
where
line
=
show
.
fst
.
loc_start
char
=
show
.
snd
.
loc_start
getLocTH
::
ExpQ
getLocTH
=
[
|
$
(
location
>>=
liftLoc
)
|
]
liftLoc
::
Loc
->
Q
Exp
liftLoc
(
Loc
a
b
c
(
d1
,
d2
)
(
e1
,
e2
))
=
[
|
Loc
$
(
TH
.
lift
a
)
$
(
TH
.
lift
b
)
$
(
TH
.
lift
c
)
(
$
(
TH
.
lift
d1
),
$
(
TH
.
lift
d2
))
(
$
(
TH
.
lift
e1
),
$
(
TH
.
lift
e2
))
|
]
-- | exception-safe combinator that creates and destroys a logger.
-- Think about it like a 'bracket' function from 'Control.Exception'.
withLogger
::
(
MonadBaseControl
IO
m
,
MonadIO
m
,
HasLogger
m
)
...
...
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