Skip to content

H
haskell-gargantext
Commit bfdb0f61 authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

Merge branch 'dev' into 86-dev-graphql

parents 2999e092 45c0817e
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 15230 additions and 76 deletions
cabal.project
View file @ bfdb0f61
......@@ -13,6 +13,11 @@ source-repository-package
location: https://gitlab.iscpif.fr/gargantext/patches-class.git
tag: 271ba32d6c940029dc653354dd7974a819f48e77
source-repository-package
type: git
location: https://gitlab.iscpif.fr/cgenie/haskell-gargantext-prelude.git
tag: 35b09629a658fc16cc9ff63e7591e58511cd98a7
-- External Data API connectors
source-repository-package
type: git
......@@ -76,7 +81,7 @@ source-repository-package
source-repository-package
type: git
location: https://github.com/delanoe/haskell-opaleye.git
tag: 63ee65d974e9d20eaaf17a2e83652175988cbb79
tag: d3ab7acd5ede737478763630035aa880f7e34444
source-repository-package
type: git
......@@ -100,4 +105,4 @@ source-repository-package
location: https://gitlab.iscpif.fr/anoe/accelerate-utility.git
tag: 83ada76e78ac10d9559af8ed6bd4064ec81308e4
constraints: unordered-containers==0.2.13.*
\ No newline at end of file
constraints: unordered-containers==0.2.14.*
\ No newline at end of file
ekg-assets/bootstrap-1.4.0.css 0 → 100755
View file @ bfdb0f61
This diff is collapsed.
ekg-assets/bootstrap-1.4.0.min.css 0 → 100755
View file @ bfdb0f61
This diff is collapsed.
ekg-assets/index.html 0 → 100644
View file @ bfdb0f61
<!DOCTYPE html>
<html>
<head>
<meta charset="utf-8">
<link rel="stylesheet" href="bootstrap-1.4.0.min.css">
<link rel="stylesheet" href="monitor.css" type="text/css">
<script type="text/javascript" src="jquery-1.6.4.min.js"></script>
<script type="text/javascript" src="jquery.flot.min.js"></script>
<title>ekg</title>
</head>
<body>
<div class="topbar">
<div class="topbar-inner">
<div class="container-fluid">
<span class="brand">ekg</span>
<p class="pull-right">Polling interval:
<select id="updateInterval" class="small">
<option value="100">100 ms</option>
<option value="200">200 ms</option>
<option value="500">500 ms</option>
<option value="1000" selected="selected">1 s</option>
<option value="2000">2 s</option>
<option value="5000">5 s</option>
<option value="10000">10 s</option>
</select> |
<button id="pause-ui" class="btn">Pause UI</button>
</p>
</div>
</div>
</div>
<div class="container">
<div class="row">
<div class="alert-message error fade in hide" data-alert="alert">
<p>Lost connection to server.</p>
</div>
</div>
<div class="row">
<div id="plots" class="span11">
<div id="current-bytes-used-plot" class="plot-container">
<h3>Current residency</h3>
<div class="plot"></div>
</div>
<div id="allocation-rate-plot" class="plot-container">
<h3>Allocation rate</h3>
<div class="plot"></div>
</div>
<div id="productivity-plot" class="plot-container">
<h3>Productivity</h3>
<div class="plot"></div>
</div>
</div>
<div class="span5">
<h3>GC and memory statistics</h3>
<table class="condensed-table">
<thead>
<tr>
<th>Statistic</th>
<th>Value</th>
</tr>
</thead>
<tbody>
<tr>
<td>Maximum residency</td>
<td id="max-bytes-used" class="span3 value">0</td>
</tr>
<tr>
<td>Current residency</td>
<td id="current-bytes-used" class="value">0</td>
</tr>
<tr>
<td>Maximum slop</td>
<td id="max-bytes-slop" class="value">0</td>
</tr>
<tr>
<td>Current slop</td>
<td id="current-bytes-slop" class="value">0</td>
</tr>
<tr>
<td>Productivity (wall clock time)</td>
<td id="productivity-wall" class="value">0</td>
</tr>
<tr>
<td>Productivity (cpu time)</td>
<td id="productivity-cpu" class="value">0</td>
</tr>
<tr>
<td>Allocation rate</td>
<td id="allocation-rate" class="value">0</td>
</tr>
</tbody>
</table>
<h3>Metrics</h3>
<table id="metric-table" class="condensed-table">
<thead>
<tr>
<th class="span4">Name</th>
<th class="span1">Value</th>
</tr>
</thead>
<tbody>
</tbody>
</table>
</div>
</div>
</div>
<script type="text/javascript" src="monitor.js"></script>
</body>
</html>
ekg-assets/jquery-1.6.4.js 0 → 100644
View file @ bfdb0f61
This diff is collapsed.
ekg-assets/jquery-1.6.4.min.js 0 → 100644
View file @ bfdb0f61
This diff is collapsed.
ekg-assets/jquery.flot.js 0 → 100644
View file @ bfdb0f61
This diff is collapsed.
ekg-assets/jquery.flot.min.js 0 → 100644
View file @ bfdb0f61
This diff is collapsed.
ekg-assets/monitor.css 0 → 100644
View file @ bfdb0f61
/**
* Blueprint/flot compatibility
*
* Resets some styles back to the browser default.
*/
.plot table {
width: auto;
border-spacing: 2px;
}
.plot th,
.plot td,
.plot caption {
padding: 0;
}
/**
* Body margin
*/
body {
padding-top: 60px;
}
/**
* Plots
*/
.plot {
width: 600px;
height: 300px;
margin-bottom: 1.5em;
}
.close-button {
float: right;
cursor: pointer;
}
/**
* Table
*/
.value {
text-align: right;
}
.string {
text-align: left;
}
.graph-button {
cursor: pointer;
vertical-align: middle;
}
ekg-assets/monitor.js 0 → 100644
View file @ bfdb0f61
This diff is collapsed.
package.yaml
View file @ bfdb0f61
......@@ -25,6 +25,15 @@ default-extensions:
- OverloadedStrings
- RankNTypes
- RecordWildCards
data-files:
- ekg-assets/index.html
- ekg-assets/monitor.js
- ekg-assets/monitor.css
- ekg-assets/jquery.flot.min.js
- ekg-assets/jquery-1.6.4.min.js
- ekg-assets/bootstrap-1.4.0.min.css
- ekg-assets/chart_line_add.png
- ekg-assets/cross.png
library:
source-dirs: src
ghc-options:
......@@ -137,6 +146,8 @@ library:
- deepseq
- directory
- duckling
- ekg-core
- ekg-json
- exceptions
- fast-logger
- fclabels
......@@ -210,6 +221,7 @@ library:
- servant-blaze
- servant-cassava
- servant-client
- servant-ekg
- servant-job
- servant-mock
- servant-multipart
......@@ -263,6 +275,7 @@ executables:
- -rtsopts
- -threaded
- -with-rtsopts=-N
- -with-rtsopts=-T
- -fprof-auto
dependencies:
- base
......
src/Gargantext/API.hs
View file @ bfdb0f61
......@@ -27,7 +27,7 @@ Pouillard (who mainly made it).
-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Gargantext.API
where
......@@ -43,6 +43,7 @@ import GHC.Generics (Generic)
import Gargantext.API.Admin.Auth.Types (AuthContext)
import Gargantext.API.Admin.Settings (newEnv)
import Gargantext.API.Admin.Types (FireWall(..), PortNumber, cookieSettings, jwtSettings, settings)
import Gargantext.API.EKG
import Gargantext.API.Ngrams (saveNodeStory)
import Gargantext.API.Prelude
import Gargantext.API.Routes
......@@ -54,11 +55,11 @@ import Network.Wai
import Network.Wai.Handler.Warp hiding (defaultSettings)
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.RequestLogger
import Paths_gargantext (getDataDir)
import Servant
import System.IO (FilePath)
import System.FilePath
data Mode = Dev | Mock | Prod
data Mode = Dev | Mock | Prod
deriving (Show, Read, Generic)
-- | startGargantext takes as parameters port number and Ini file.
......@@ -191,8 +192,14 @@ serverGargAdminAPI = roots
--gargMock :: Server GargAPI
--gargMock = mock apiGarg Proxy
---------------------------------------------------------------------
makeApp :: (Typeable env, EnvC env) => env -> IO Application
makeApp env = serveWithContext api cfg <$> server env
makeApp env = do
serv <- server env
(ekgStore, ekgMid) <- newEkgStore api
ekgDir <- (</> "ekg-assets") <$> getDataDir
return $ ekgMid $ serveWithContext apiWithEkg cfg
(ekgServer ekgDir ekgStore :<|> serv)
where
cfg :: Servant.Context AuthContext
cfg = env ^. settings . jwtSettings
......@@ -206,6 +213,9 @@ makeApp env = serveWithContext api cfg <$> server env
api :: Proxy API
api = Proxy
apiWithEkg :: Proxy (EkgAPI :<|> API)
apiWithEkg = Proxy
apiGarg :: Proxy GargAPI
apiGarg = Proxy
---------------------------------------------------------------------
......
src/Gargantext/API/EKG.hs 0 → 100644
View file @ bfdb0f61
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Gargantext.API.EKG where
import Data.HashMap.Strict as HM
import Data.Text as T
import Data.Text.IO as T
import Data.Time.Clock.POSIX (getPOSIXTime)
import Network.Wai
import Protolude
import Servant
import Servant.Auth
import Servant.Ekg
import System.Metrics
import qualified System.Metrics.Json as J
-- Mimics https://github.com/tibbe/ekg/blob/master/System/Remote/Snap.hs#L98
type EkgAPI =
"ekg" :>
( "api" :>
( Get '[JSON] J.Sample :<|>
CaptureAll "segments" Text :> Get '[JSON] J.Value
) :<|>
Raw
)
ekgServer :: FilePath -> Store -> Server EkgAPI
ekgServer assetsDir store = (getAll :<|> getOne) :<|> serveDirectoryFileServer assetsDir
where getAll = J.Sample <$> liftIO (sampleAll store)
getOne segments = do
let metric = T.intercalate "." segments
metrics <- liftIO (sampleAll store)
maybe (liftIO (T.putStrLn "not found boohoo") >> throwError err404) (return . J.Value) (HM.lookup metric metrics)
newEkgStore :: HasEndpoint api => Proxy api -> IO (Store, Middleware)
newEkgStore api = do
s <- newStore
registerGcMetrics s
registerCounter "ekg.server_timestamp_ms" getTimeMs s -- used by UI
mid <- monitorEndpoints api s
return (s, mid)
where getTimeMs = (round . (* 1000)) `fmap` getPOSIXTime
instance HasEndpoint api => HasEndpoint (Auth xs a :> api) where
getEndpoint _ = getEndpoint (Proxy :: Proxy api)
enumerateEndpoints _ = enumerateEndpoints (Proxy :: Proxy api)
src/Gargantext/Core/Text/Corpus/Parsers/FrameWrite.hs
View file @ bfdb0f61
......@@ -178,7 +178,7 @@ datePrefixP = do
dateP :: Parser Date
dateP = try datePrefixP
*> dateISOP
-- *> many (noneOf "\n")
-- *> many (noneOf "\n")
dateISOP :: Parser Date
dateISOP = do
......
src/Gargantext/Database/Admin/Types/Hyperdata/Contact.hs
View file @ bfdb0f61
......@@ -34,15 +34,14 @@ import Gargantext.Utils.UTCTime
--------------------------------------------------------------------------------
data HyperdataContact =
HyperdataContact { _hc_bdd :: Maybe Text -- ID of Database source
, _hc_who :: Maybe ContactWho
, _hc_where :: [ContactWhere]
, _hc_title :: Maybe Text -- TODO remove (only demo)
, _hc_source :: Maybe Text -- TODO remove (only demo)
, _hc_lastValidation :: Maybe Text -- TODO UTCTime
, _hc_uniqIdBdd :: Maybe Text
, _hc_uniqId :: Maybe Text
HyperdataContact { _hc_bdd :: Maybe Text -- ID of Database source
, _hc_who :: Maybe ContactWho
, _hc_where :: [ContactWhere]
, _hc_title :: Maybe Text -- TODO remove (only demo)
, _hc_source :: Maybe Text -- TODO remove (only demo)
, _hc_lastValidation :: Maybe Text -- TODO UTCTime
, _hc_uniqIdBdd :: Maybe Text
, _hc_uniqId :: Maybe Text
} deriving (Eq, Show, Generic)
instance GQLType HyperdataContact where
......@@ -53,46 +52,57 @@ instance HasText HyperdataContact
hasText = undefined
defaultHyperdataContact :: HyperdataContact
defaultHyperdataContact = HyperdataContact (Just "bdd")
(Just defaultContactWho)
[defaultContactWhere]
(Just "Title")
(Just "Source")
(Just "TODO lastValidation date")
(Just "DO NOT expose this")
(Just "DO NOT expose this")
defaultHyperdataContact =
HyperdataContact
{ _hc_bdd = Just "bdd"
, _hc_who = Just defaultContactWho
, _hc_where = [defaultContactWhere]
, _hc_title =Just "Title"
, _hc_source = Just "Source"
, _hc_lastValidation = Just "TODO lastValidation date"
, _hc_uniqIdBdd = Just "DO NOT expose this"
, _hc_uniqId = Just "DO NOT expose this" }
hyperdataContact :: FirstName -> LastName -> HyperdataContact
hyperdataContact fn ln = HyperdataContact Nothing
(Just (contactWho fn ln))
[]
Nothing
Nothing
Nothing
Nothing
Nothing
hyperdataContact fn ln =
HyperdataContact
{ _hc_bdd = Nothing
, _hc_who = Just (contactWho fn ln)
, _hc_where = []
, _hc_title = Nothing
, _hc_source = Nothing
, _hc_lastValidation = Nothing
, _hc_uniqIdBdd = Nothing
, _hc_uniqId = Nothing }
-- TOD0 contact metadata (Type is too flat)
data ContactMetaData =
ContactMetaData { _cm_bdd :: Maybe Text
, _cm_lastValidation :: Maybe Text -- TODO UTCTIME
ContactMetaData { _cm_bdd :: Maybe Text
, _cm_lastValidation :: Maybe Text -- TODO UTCTIME
} deriving (Eq, Show, Generic)
defaultContactMetaData :: ContactMetaData
defaultContactMetaData = ContactMetaData (Just "bdd") (Just "TODO UTCTime")
arbitraryHyperdataContact :: HyperdataContact
arbitraryHyperdataContact = HyperdataContact Nothing Nothing []
Nothing Nothing Nothing
Nothing Nothing
arbitraryHyperdataContact =
HyperdataContact
{ _hc_bdd = Nothing
, _hc_who = Nothing
, _hc_where = []
, _hc_title = Nothing
, _hc_source = Nothing
, _hc_lastValidation = Nothing
, _hc_uniqIdBdd = Nothing
, _hc_uniqId = Nothing }
data ContactWho =
ContactWho { _cw_id :: Maybe Text
, _cw_firstName :: Maybe Text
, _cw_lastName :: Maybe Text
, _cw_keywords :: [Text]
, _cw_freetags :: [Text]
ContactWho { _cw_id :: Maybe Text
, _cw_firstName :: Maybe Text
, _cw_lastName :: Maybe Text
, _cw_keywords :: [Text]
, _cw_freetags :: [Text]
} deriving (Eq, Show, Generic)
instance GQLType ContactWho where
......@@ -105,41 +115,44 @@ defaultContactWho :: ContactWho
defaultContactWho = contactWho "Pierre" "Dupont"
contactWho :: FirstName -> LastName -> ContactWho
contactWho fn ln = ContactWho { _cw_id = Nothing
, _cw_firstName = Just fn
, _cw_lastName = Just ln
, _cw_keywords = []
, _cw_freetags = [] }
contactWho fn ln =
ContactWho { _cw_id = Nothing
, _cw_firstName = Just fn
, _cw_lastName = Just ln
, _cw_keywords = []
, _cw_freetags = [] }
data ContactWhere =
ContactWhere { _cw_organization :: [Text]
, _cw_labTeamDepts :: [Text]
, _cw_role :: Maybe Text
, _cw_office :: Maybe Text
, _cw_country :: Maybe Text
, _cw_city :: Maybe Text
, _cw_touch :: Maybe ContactTouch
, _cw_entry :: Maybe NUTCTime
, _cw_exit :: Maybe NUTCTime
ContactWhere { _cw_organization :: [Text]
, _cw_labTeamDepts :: [Text]
, _cw_role :: Maybe Text
, _cw_office :: Maybe Text
, _cw_country :: Maybe Text
, _cw_city :: Maybe Text
, _cw_touch :: Maybe ContactTouch
, _cw_entry :: Maybe NUTCTime
, _cw_exit :: Maybe NUTCTime
} deriving (Eq, Show, Generic)
instance GQLType ContactWhere where
typeOptions _ = GAGU.unPrefix "_cw_"
defaultContactWhere :: ContactWhere
defaultContactWhere = ContactWhere ["Organization X"]
["Lab Z"]
(Just "Role")
(Just "Office")
(Just "Country")
(Just "City")
(Just defaultContactTouch)
(Just $ NUTCTime $ jour 01 01 2020)
(Just $ NUTCTime $ jour 01 01 2029)
defaultContactWhere =
ContactWhere
{ _cw_organization = ["Organization X"]
, _cw_labTeamDepts = ["Lab Z"]
, _cw_role = Just "Role"
, _cw_office = Just "Office"
, _cw_country = Just "Country"
, _cw_city = Just "City"
, _cw_touch = Just defaultContactTouch
, _cw_entry = Just $ NUTCTime $ jour 01 01 2020
, _cw_exit = Just $ NUTCTime $ jour 01 01 2029 }
data ContactTouch =
ContactTouch { _ct_mail :: Maybe Text
......@@ -151,9 +164,11 @@ instance GQLType ContactTouch where
typeOptions _ = GAGU.unPrefix "_ct_"
defaultContactTouch :: ContactTouch
defaultContactTouch = ContactTouch (Just "email@data.com")
(Just "+336 328 283 288")
(Just "https://url.com")
defaultContactTouch =
ContactTouch
{ _ct_mail = Just "email@data.com"
, _ct_phone = Just "+336 328 283 288"
, _ct_url = Just "https://url.com" }
-- | ToSchema instances
instance ToSchema HyperdataContact where
......
src/Gargantext/Database/Admin/Types/Hyperdata/User.hs
View file @ bfdb0f61
......@@ -64,9 +64,11 @@ instance GQLType HyperdataPublic where
-- | Default
defaultHyperdataUser :: HyperdataUser
defaultHyperdataUser = HyperdataUser (Just defaultHyperdataPrivate)
(Just defaultHyperdataContact)
(Just defaultHyperdataPublic)
defaultHyperdataUser =
HyperdataUser
{ _hu_private = Just defaultHyperdataPrivate
, _hu_shared = Just defaultHyperdataContact
, _hu_public = Just defaultHyperdataPublic }
defaultHyperdataPublic :: HyperdataPublic
defaultHyperdataPublic = HyperdataPublic "pseudo" [1..10]
......
src/Gargantext/Database/Query/Table/User.hs
View file @ bfdb0f61
......@@ -24,6 +24,7 @@ module Gargantext.Database.Query.Table.User
, updateUserDB
, queryUserTable
, getUserHyperdata
, getUsersWithHyperdata
, getUser
, insertNewUsers
, selectUsersLightWith
......@@ -124,6 +125,12 @@ getUserHyperdata i = do
row <- queryNodeTable -< ()
restrict -< row^.node_id .== (sqlInt4 i')
returnA -< row^.node_hyperdata
getUsersWithHyperdata :: Int -> Cmd err [(UserLight, HyperdataUser)]
getUsersWithHyperdata i = do
u <- getUsersWithId i
h <- getUserHyperdata i
pure $ zip u h
------------------------------------------------------------------
-- | Select User with some parameters
-- Not optimized version
......
stack.yaml
View file @ bfdb0f61
......@@ -121,3 +121,4 @@ extra-deps:
# need Vector.uncons
- vector-0.12.3.0@sha256:0ae2c1ba86f0077910be242ec6802cc3d7725fe7b2bea6987201aa3737b239b5,7953
- servant-ekg-0.3.1@sha256:19bd9dc3943983da8e79d6f607614c68faea4054fb889d508c8a2b67b6bdd448,2203
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