Skip to content

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

Merge branch 'update-build-shell.nix' of... 

Merge branch 'update-build-shell.nix' of ssh://gitlab.iscpif.fr:20022/gargantext/haskell-gargantext into update-build-shell.nix
parents 2bb76491 04c919a6
Hide whitespace changes
Inline Side-by-side
Showing with 224 additions and 79 deletions
README.md
View file @ c3fec4af
...@@ -72,7 +72,14 @@ stack install ...@@ -72,7 +72,14 @@ stack install
~/.local/bin/gargantext-init "gargantext.ini" ~/.local/bin/gargantext-init "gargantext.ini"
``` ```
For Docker env, run: For Docker env, first create the appropriate image:
``` sh
cd devops/docker
docker build -t fpco/stack-build:lts-14.27-garg .
```
then run:
``` sh ``` sh
stack --docker run gargantext-init -- gargantext.ini stack --docker run gargantext-init -- gargantext.ini
......
devops/docker/Dockerfile
View file @ c3fec4af
from fpco/stack-build:lts-14.6 from fpco/stack-build:lts-14.27
RUN apt-get update && \ RUN apt-get update && \
apt-get install -y git libigraph0-dev && \ apt-get install -y git libigraph0-dev && \
......
src/Gargantext/API.hs
View file @ c3fec4af
...@@ -164,7 +164,7 @@ makeDevMiddleware = do ...@@ -164,7 +164,7 @@ makeDevMiddleware = do
-- True -> app req resp -- True -> app req resp
-- False -> resp ( responseLBS status401 [] -- False -> resp ( responseLBS status401 []
-- "Invalid Origin or Host header") -- "Invalid Origin or Host header")
-- --
let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy let corsMiddleware = cors $ \_ -> Just CorsResourcePolicy
-- { corsOrigins = Just ([env^.settings.allowedOrigin], False) -- { corsOrigins = Just ([env^.settings.allowedOrigin], False)
{ corsOrigins = Nothing -- == /* { corsOrigins = Nothing -- == /*
...@@ -180,7 +180,7 @@ makeDevMiddleware = do ...@@ -180,7 +180,7 @@ makeDevMiddleware = do
--let warpS = Warp.setPort (8008 :: Int) -- (env^.settings.appPort) --let warpS = Warp.setPort (8008 :: Int) -- (env^.settings.appPort)
-- $ Warp.defaultSettings -- $ Warp.defaultSettings
--pure (warpS, logWare . checkOriginAndHost . corsMiddleware) --pure (warpS, logWare . checkOriginAndHost . corsMiddleware)
pure $ logStdoutDev . corsMiddleware pure $ logStdoutDev . corsMiddleware
...@@ -208,7 +208,7 @@ type GargAPI' = ...@@ -208,7 +208,7 @@ type GargAPI' =
-- auth and capabilities. -- auth and capabilities.
:<|> GargPrivateAPI :<|> GargPrivateAPI
type GargPrivateAPI = SA.Auth '[SA.JWT] AuthenticatedUser :> GargPrivateAPI' type GargPrivateAPI = SA.Auth '[SA.JWT, SA.Cookie] AuthenticatedUser :> GargPrivateAPI'
type GargAdminAPI type GargAdminAPI
-- Roots endpoint -- Roots endpoint
...@@ -234,58 +234,60 @@ type GargPrivateAPI' = ...@@ -234,58 +234,60 @@ type GargPrivateAPI' =
GargAdminAPI GargAdminAPI
-- Node endpoint -- Node endpoint
:<|> "node" :> Summary "Node endpoint" :<|> "node" :> Summary "Node endpoint"
:> Capture "node_id" NodeId :> Capture "node_id" NodeId
:> NodeAPI HyperdataAny :> NodeAPI HyperdataAny
-- Corpus endpoints -- Corpus endpoints
:<|> "corpus":> Summary "Corpus endpoint" :<|> "corpus" :> Summary "Corpus endpoint"
:> Capture "corpus_id" CorpusId :> Capture "corpus_id" CorpusId
:> NodeAPI HyperdataCorpus :> NodeAPI HyperdataCorpus
:<|> "corpus":> Summary "Corpus endpoint" :<|> "corpus" :> Summary "Corpus endpoint"
:> Capture "node1_id" NodeId :> Capture "node1_id" NodeId
:> "document" :> "document"
:> Capture "node2_id" NodeId :> Capture "node2_id" NodeId
:> NodeNodeAPI HyperdataAny :> NodeNodeAPI HyperdataAny
:<|> "corpus" :> Capture "node_id" CorpusId :<|> "corpus" :> Capture "node_id" CorpusId
:> Export.API :> Export.API
-- Annuaire endpoint -- Annuaire endpoint
:<|> "annuaire":> Summary "Annuaire endpoint" :<|> "annuaire" :> Summary "Annuaire endpoint"
:> Capture "annuaire_id" AnnuaireId :> Capture "annuaire_id" AnnuaireId
:> NodeAPI HyperdataAnnuaire :> NodeAPI HyperdataAnnuaire
:<|> "annuaire" :> Summary "Contact endpoint" :<|> "annuaire" :> Summary "Contact endpoint"
:> Capture "annuaire_id" NodeId :> Capture "annuaire_id" NodeId
:> "contact" :> Capture "contact_id" NodeId :> "contact"
:> Capture "contact_id" NodeId
:> NodeNodeAPI HyperdataContact :> NodeNodeAPI HyperdataContact
-- Document endpoint -- Document endpoint
:<|> "document":> Summary "Document endpoint" :<|> "document" :> Summary "Document endpoint"
:> Capture "doc_id" DocId :> Capture "doc_id" DocId
:> "ngrams" :> TableNgramsApi :> "ngrams" :> TableNgramsApi
-- :<|> "counts" :> Stream GET NewLineFraming '[JSON] Count :> CountAPI -- :<|> "counts" :> Stream GET NewLineFraming '[JSON] Count :> CountAPI
-- TODO-SECURITY -- TODO-SECURITY
:<|> "count" :> Summary "Count endpoint" :<|> "count" :> Summary "Count endpoint"
:> ReqBody '[JSON] Query :> CountAPI :> ReqBody '[JSON] Query
:> CountAPI
-- Corpus endpoint --> TODO rename s/search/filter/g -- Corpus endpoint --> TODO rename s/search/filter/g
:<|> "search":> Capture "corpus" NodeId :<|> "search" :> Capture "corpus" NodeId
:> SearchPairsAPI :> SearchPairsAPI
-- TODO move to NodeAPI? -- TODO move to NodeAPI?
:<|> "graph" :> Summary "Graph endpoint" :<|> "graph" :> Summary "Graph endpoint"
:> Capture "graph_id" NodeId :> Capture "graph_id" NodeId
:> GraphAPI :> GraphAPI
-- TODO move to NodeAPI? -- TODO move to NodeAPI?
-- Tree endpoint -- Tree endpoint
:<|> "tree" :> Summary "Tree endpoint" :<|> "tree" :> Summary "Tree endpoint"
:> Capture "tree_id" NodeId :> Capture "tree_id" NodeId
:> TreeAPI :> TreeAPI
-- :<|> New.Upload -- :<|> New.Upload
:<|> New.AddWithForm :<|> New.AddWithForm
...@@ -296,13 +298,13 @@ type GargPrivateAPI' = ...@@ -296,13 +298,13 @@ type GargPrivateAPI' =
-- :<|> "scraper" :> WithCallbacks ScraperAPI -- :<|> "scraper" :> WithCallbacks ScraperAPI
-- :<|> "new" :> New.Api -- :<|> "new" :> New.Api
:<|> "list" :> Summary "List export API" :<|> "lists" :> Summary "List export API"
:> Capture "listId" ListId :> Capture "listId" ListId
:> List.API :> List.API
:<|> "wait" :> Summary "Wait test" :<|> "wait" :> Summary "Wait test"
:> Capture "x" Int :> Capture "x" Int
:> WaitAPI -- Get '[JSON] Int :> WaitAPI -- Get '[JSON] Int
-- /mv/<id>/<id> -- /mv/<id>/<id>
-- /merge/<id>/<id> -- /merge/<id>/<id>
...@@ -470,7 +472,7 @@ type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n)) ...@@ -470,7 +472,7 @@ type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
swaggerDoc :: Swagger swaggerDoc :: Swagger
swaggerDoc = toSwagger (Proxy :: Proxy GargAPI) swaggerDoc = toSwagger (Proxy :: Proxy GargAPI)
& info.title .~ "Gargantext" & info.title .~ "Gargantext"
& info.version .~ "4.0.2" -- TODO same version as Gargantext & info.version .~ "0.0.1.3.1" -- TODO same version as Gargantext
-- & info.base_url ?~ (URL "http://gargantext.org/") -- & info.base_url ?~ (URL "http://gargantext.org/")
& info.description ?~ "REST API specifications" & info.description ?~ "REST API specifications"
-- & tags .~ Set.fromList [Tag "Garg" (Just "Main perations") Nothing] -- & tags .~ Set.fromList [Tag "Garg" (Just "Main perations") Nothing]
......
src/Gargantext/API/Corpus/New.hs
View file @ c3fec4af
...@@ -20,6 +20,7 @@ New corpus means either: ...@@ -20,6 +20,7 @@ New corpus means either:
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Gargantext.API.Corpus.New module Gargantext.API.Corpus.New
where where
...@@ -77,10 +78,15 @@ instance Arbitrary Query where ...@@ -77,10 +78,15 @@ instance Arbitrary Query where
instance ToSchema Query where instance ToSchema Query where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "query_") declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "query_")
type Api = Summary "New Corpus endpoint" ------------------------------------------------------------------------
:> ReqBody '[JSON] Query
:> Post '[JSON] CorpusId type Api = PostApi
:<|> Get '[JSON] ApiInfo :<|> GetApi
type PostApi = Summary "New Corpus endpoint"
:> ReqBody '[JSON] Query
:> Post '[JSON] CorpusId
type GetApi = Get '[JSON] ApiInfo
-- | TODO manage several apis -- | TODO manage several apis
-- TODO-ACCESS -- TODO-ACCESS
...@@ -130,6 +136,7 @@ data WithForm = WithForm ...@@ -130,6 +136,7 @@ data WithForm = WithForm
{ _wf_filetype :: !FileType { _wf_filetype :: !FileType
, _wf_data :: !Text , _wf_data :: !Text
, _wf_lang :: !(Maybe Lang) , _wf_lang :: !(Maybe Lang)
, _wf_name :: !Text
} deriving (Eq, Show, Generic) } deriving (Eq, Show, Generic)
makeLenses ''WithForm makeLenses ''WithForm
...@@ -147,8 +154,8 @@ type AsyncJobs event ctI input output = ...@@ -147,8 +154,8 @@ type AsyncJobs event ctI input output =
type Upload = Summary "Corpus Upload endpoint" type Upload = Summary "Corpus Upload endpoint"
:> "corpus" :> "corpus"
:> Capture "corpus_id" CorpusId :> Capture "corpus_id" CorpusId
:<|> "addWithquery" :> AsyncJobsAPI ScraperStatus WithQuery ScraperStatus :<|> "addWithquery" :> AsyncJobsAPI ScraperStatus WithQuery ScraperStatus
:<|> "addWithfile" :> AsyncJobs ScraperStatus '[FormUrlEncoded] WithForm ScraperStatus :<|> "addWithfile" :> AsyncJobs ScraperStatus '[FormUrlEncoded] WithForm ScraperStatus
type AddWithQuery = Summary "Add with Query to corpus endpoint" type AddWithQuery = Summary "Add with Query to corpus endpoint"
...@@ -241,7 +248,7 @@ addToCorpusWithForm :: FlowCmdM env err m ...@@ -241,7 +248,7 @@ addToCorpusWithForm :: FlowCmdM env err m
-> WithForm -> WithForm
-> (ScraperStatus -> m ()) -> (ScraperStatus -> m ())
-> m ScraperStatus -> m ScraperStatus
addToCorpusWithForm cid (WithForm ft d l) logStatus = do addToCorpusWithForm cid (WithForm ft d l _n) logStatus = do
printDebug "ft" ft printDebug "ft" ft
......
src/Gargantext/API/Ngrams.hs
View file @ c3fec4af
...@@ -39,6 +39,8 @@ module Gargantext.API.Ngrams ...@@ -39,6 +39,8 @@ module Gargantext.API.Ngrams
, TableNgramsApiPost , TableNgramsApiPost
, getTableNgrams , getTableNgrams
, setListNgrams
, rmListNgrams
, putListNgrams , putListNgrams
, putListNgrams' , putListNgrams'
, tableNgramsPost , tableNgramsPost
...@@ -116,13 +118,14 @@ import Data.Map.Strict (Map) ...@@ -116,13 +118,14 @@ import Data.Map.Strict (Map)
import qualified Data.Set as Set import qualified Data.Set as Set
import Control.Category ((>>>)) import Control.Category ((>>>))
import Control.Concurrent import Control.Concurrent
import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^..), (^?), (+~), (%~), (%=), sumOf, at, _Just, Each(..), itraverse_, both, forOf_, (%%~), (?~), mapped) import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^..), (^?), (+~), (%~), (.~), (%=), sumOf, at, _Just, Each(..), itraverse_, both, forOf_, (%%~), (?~), mapped)
import Control.Monad.Error.Class (MonadError) import Control.Monad.Error.Class (MonadError)
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.State import Control.Monad.State
import Data.Aeson hiding ((.=)) import Data.Aeson hiding ((.=))
import Data.Aeson.TH (deriveJSON) import Data.Aeson.TH (deriveJSON)
import Data.Either(Either(Left)) import Data.Either(Either(Left))
import Data.Either.Extra (maybeToEither)
-- import Data.Map (lookup) -- import Data.Map (lookup)
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import Data.Swagger hiding (version, patch) import Data.Swagger hiding (version, patch)
...@@ -168,14 +171,14 @@ instance FromHttpApiData TabType ...@@ -168,14 +171,14 @@ instance FromHttpApiData TabType
parseUrlPiece "Trash" = pure Trash parseUrlPiece "Trash" = pure Trash
parseUrlPiece "MoreFav" = pure MoreFav parseUrlPiece "MoreFav" = pure MoreFav
parseUrlPiece "MoreTrash" = pure MoreTrash parseUrlPiece "MoreTrash" = pure MoreTrash
parseUrlPiece "Terms" = pure Terms parseUrlPiece "Terms" = pure Terms
parseUrlPiece "Sources" = pure Sources parseUrlPiece "Sources" = pure Sources
parseUrlPiece "Institutes" = pure Institutes parseUrlPiece "Institutes" = pure Institutes
parseUrlPiece "Authors" = pure Authors parseUrlPiece "Authors" = pure Authors
parseUrlPiece "Contacts" = pure Contacts parseUrlPiece "Contacts" = pure Contacts
parseUrlPiece _ = Left "Unexpected value of TabType" parseUrlPiece _ = Left "Unexpected value of TabType"
instance ToParamSchema TabType instance ToParamSchema TabType
...@@ -662,7 +665,7 @@ data Versioned a = Versioned ...@@ -662,7 +665,7 @@ data Versioned a = Versioned
{ _v_version :: Version { _v_version :: Version
, _v_data :: a , _v_data :: a
} }
deriving (Generic, Show) deriving (Generic, Show, Eq)
deriveJSON (unPrefix "_v_") ''Versioned deriveJSON (unPrefix "_v_") ''Versioned
makeLenses ''Versioned makeLenses ''Versioned
instance ToSchema a => ToSchema (Versioned a) where instance ToSchema a => ToSchema (Versioned a) where
...@@ -670,8 +673,9 @@ instance ToSchema a => ToSchema (Versioned a) where ...@@ -670,8 +673,9 @@ instance ToSchema a => ToSchema (Versioned a) where
instance Arbitrary a => Arbitrary (Versioned a) where instance Arbitrary a => Arbitrary (Versioned a) where
arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far arbitrary = Versioned 1 <$> arbitrary -- TODO 1 is constant so far
{- {-
-- TODO sequencs of modifications (Patchs) -- TODO sequences of modifications (Patchs)
type NgramsIdPatch = Patch NgramsId NgramsPatch type NgramsIdPatch = Patch NgramsId NgramsPatch
ngramsPatch :: Int -> NgramsPatch ngramsPatch :: Int -> NgramsPatch
...@@ -852,6 +856,32 @@ addListNgrams listId ngramsType nes = do ...@@ -852,6 +856,32 @@ addListNgrams listId ngramsType nes = do
m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes m = Map.fromList $ (\n -> (n ^. ne_ngrams, n)) <$> nes
-} -}
rmListNgrams :: RepoCmdM env err m
=> ListId
-> NgramsType
-> m ()
rmListNgrams l nt = setListNgrams l nt mempty
-- | TODO: incr the Version number
-- && should use patch
setListNgrams :: RepoCmdM env err m
=> NodeId
-> NgramsType
-> Map NgramsTerm NgramsRepoElement
-> m ()
setListNgrams listId ngramsType ns = do
var <- view repoVar
liftIO $ modifyMVar_ var $
pure . ( r_state
. at ngramsType %~
(Just .
(at listId .~ ( Just ns))
. something
)
)
saveRepo
-- If the given list of ngrams elements contains ngrams already in -- If the given list of ngrams elements contains ngrams already in
-- the repo, they will be ignored. -- the repo, they will be ignored.
putListNgrams :: RepoCmdM env err m putListNgrams :: RepoCmdM env err m
...@@ -1100,7 +1130,6 @@ getTableNgrams _nType nId tabType listId limit_ offset ...@@ -1100,7 +1130,6 @@ getTableNgrams _nType nId tabType listId limit_ offset
-- TODO: find a better place for the code above, All APIs stay here -- TODO: find a better place for the code above, All APIs stay here
type QueryParamR = QueryParam' '[Required, Strict] type QueryParamR = QueryParam' '[Required, Strict]
data OrderBy = TermAsc | TermDesc | ScoreAsc | ScoreDesc data OrderBy = TermAsc | TermDesc | ScoreAsc | ScoreDesc
deriving (Generic, Enum, Bounded, Read, Show) deriving (Generic, Enum, Bounded, Read, Show)
...@@ -1112,6 +1141,7 @@ instance FromHttpApiData OrderBy ...@@ -1112,6 +1141,7 @@ instance FromHttpApiData OrderBy
parseUrlPiece "ScoreDesc" = pure ScoreDesc parseUrlPiece "ScoreDesc" = pure ScoreDesc
parseUrlPiece _ = Left "Unexpected value of OrderBy" parseUrlPiece _ = Left "Unexpected value of OrderBy"
instance ToParamSchema OrderBy instance ToParamSchema OrderBy
instance FromJSON OrderBy instance FromJSON OrderBy
instance ToJSON OrderBy instance ToJSON OrderBy
...@@ -1205,8 +1235,8 @@ apiNgramsTableDoc :: ( RepoCmdM env err m ...@@ -1205,8 +1235,8 @@ apiNgramsTableDoc :: ( RepoCmdM env err m
apiNgramsTableDoc dId = getTableNgramsDoc dId apiNgramsTableDoc dId = getTableNgramsDoc dId
:<|> tableNgramsPut :<|> tableNgramsPut
:<|> tableNgramsPost :<|> tableNgramsPost
-- > add new ngrams in database (TODO AD) -- > add new ngrams in database (TODO AD)
-- > index all the corpus accordingly (TODO AD) -- > index all the corpus accordingly (TODO AD)
listNgramsChangedSince :: RepoCmdM env err m listNgramsChangedSince :: RepoCmdM env err m
=> ListId -> NgramsType -> Version -> m (Versioned Bool) => ListId -> NgramsType -> Version -> m (Versioned Bool)
...@@ -1222,3 +1252,7 @@ instance Arbitrary NgramsRepoElement where ...@@ -1222,3 +1252,7 @@ instance Arbitrary NgramsRepoElement where
where where
NgramsTable ns = mockTable NgramsTable ns = mockTable
--{-
instance FromHttpApiData (Map NgramsType (Versioned NgramsTableMap))
where
parseUrlPiece x = maybeToEither x (decode $ cs x)
src/Gargantext/API/Ngrams/List.hs
View file @ c3fec4af
...@@ -12,6 +12,8 @@ Portability : POSIX ...@@ -12,6 +12,8 @@ Portability : POSIX
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
...@@ -21,40 +23,126 @@ Portability : POSIX ...@@ -21,40 +23,126 @@ Portability : POSIX
module Gargantext.API.Ngrams.List module Gargantext.API.Ngrams.List
where where
import Gargantext.Prelude import Control.Lens hiding (elements)
import Gargantext.API.Ngrams import Control.Monad.IO.Class (liftIO)
import Servant import Data.Aeson
import Data.List (zip) import Data.List (zip)
import Data.Map (Map, toList, fromList) import Data.Map (Map, toList, fromList)
import Gargantext.Database.Types.Node import Data.Swagger (ToSchema, declareNamedSchema, genericDeclareNamedSchema)
import Gargantext.Database.Schema.Ngrams (NgramsType(..), ngramsTypes) import Data.Text (Text, concat, pack)
import Gargantext.Database.Flow (FlowCmdM) import GHC.Generics (Generic)
import Gargantext.API.Corpus.New
import Gargantext.API.Corpus.New.File (FileType(..))
import Gargantext.API.Ngrams
import Gargantext.API.Orchestrator.Types
import Gargantext.API.Types (GargServer) import Gargantext.API.Types (GargServer)
import Gargantext.API.Ngrams (putListNgrams') import Gargantext.Database.Flow (FlowCmdM)
import Gargantext.Database.Schema.Ngrams (NgramsType(..), ngramsTypes)
import Gargantext.Database.Types.Node
import Gargantext.Core.Utils.Prefix (unPrefixSwagger)
import Gargantext.Prelude
import Network.HTTP.Media ((//), (/:))
import Servant
import Servant.Job.Async
import Web.FormUrlEncoded (FromForm)
import Servant.Job.Utils (jsonOptions)
------------------------------------------------------------------------
type NgramsList = (Map NgramsType (Versioned NgramsTableMap)) type NgramsList = (Map NgramsType (Versioned NgramsTableMap))
------------------------------------------------------------------------
type API = Get '[JSON] NgramsList type API = Get '[HTML] (Headers '[Header "Content-Disposition" Text] NgramsList)
:<|> ReqBody '[JSON] NgramsList :> Put '[JSON] Bool -- :<|> ReqBody '[JSON] NgramsList :> Post '[JSON] Bool
:<|> PostAPI
api :: ListId -> GargServer API api :: ListId -> GargServer API
api l = get l :<|> put l api l =
get l
:<|>
-- post l
postAsync l
data HTML
instance Accept HTML where
contentType _ = "text" // "html" /: ("charset", "utf-8")
instance ToJSON a => MimeRender HTML a where
mimeRender _ = encode
------------------------------------------------------------------------
get :: RepoCmdM env err m get :: RepoCmdM env err m
=> ListId -> m (Headers '[Header "Content-Disposition" Text] NgramsList)
get lId = do
lst <- get' lId
let (NodeId id) = lId
return $ addHeader (concat [ "attachment; filename=GarganText_NgramsList-"
, pack $ show id
, ".json"
]
) lst
get' :: RepoCmdM env err m
=> ListId -> m NgramsList => ListId -> m NgramsList
get lId = fromList get' lId = fromList
<$> zip ngramsTypes <$> zip ngramsTypes
<$> mapM (getNgramsTableMap lId) ngramsTypes <$> mapM (getNgramsTableMap lId) ngramsTypes
------------------------------------------------------------------------
-- TODO : purge list -- TODO : purge list
put :: FlowCmdM env err m post :: FlowCmdM env err m
=> ListId => ListId
-> NgramsList -> NgramsList
-> m Bool -> m Bool
put l m = do post l m = do
-- TODO check with Version for optim -- TODO check with Version for optim
_ <- mapM (\(nt, Versioned _v ns) -> putListNgrams' l nt ns) $ toList m _ <- mapM (\(nt, Versioned _v ns) -> setListNgrams l nt ns) $ toList m
-- TODO reindex -- TODO reindex
pure True pure True
------------------------------------------------------------------------
------------------------------------------------------------------------
type PostAPI = Summary "Update List"
:> "add"
:> "form"
:> "async"
:> AsyncJobs ScraperStatus '[FormUrlEncoded] WithFile ScraperStatus
postAsync :: ListId -> GargServer PostAPI
postAsync lId =
serveJobsAPI $
JobFunction (\f log' -> postAsync' lId f (liftIO . log'))
postAsync' :: FlowCmdM env err m
=> ListId
-> WithFile
-> (ScraperStatus -> m ())
-> m ScraperStatus
postAsync' l (WithFile _ m _) logStatus = do
logStatus ScraperStatus { _scst_succeeded = Just 0
, _scst_failed = Just 0
, _scst_remaining = Just 1
, _scst_events = Just []
}
_r <- post l m
pure ScraperStatus { _scst_succeeded = Just 1
, _scst_failed = Just 0
, _scst_remaining = Just 0
, _scst_events = Just []
}
data WithFile = WithFile
{ _wf_filetype :: !FileType
, _wf_data :: !NgramsList
, _wf_name :: !Text
} deriving (Eq, Show, Generic)
makeLenses ''WithFile
instance FromForm WithFile
instance FromJSON WithFile where
parseJSON = genericParseJSON $ jsonOptions "_wf_"
instance ToSchema WithFile where
declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "_wf_")
src/Gargantext/API/Settings.hs
View file @ c3fec4af
...@@ -48,7 +48,7 @@ import Data.ByteString (ByteString) ...@@ -48,7 +48,7 @@ import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as L
import Servant import Servant
import Servant.Auth.Server (defaultJWTSettings, JWTSettings, CookieSettings, defaultCookieSettings, readKey, writeKey) import Servant.Auth.Server (defaultJWTSettings, JWTSettings, CookieSettings(..), XsrfCookieSettings(..), defaultCookieSettings, defaultXsrfCookieSettings, readKey, writeKey)
import Servant.Client (BaseUrl, parseBaseUrl) import Servant.Client (BaseUrl, parseBaseUrl)
import qualified Servant.Job.Core import qualified Servant.Job.Core
import Servant.Job.Async (newJobEnv, defaultSettings, HasJobEnv(..), Job) import Servant.Job.Async (newJobEnv, defaultSettings, HasJobEnv(..), Job)
...@@ -106,9 +106,11 @@ devSettings jwkFile = do ...@@ -106,9 +106,11 @@ devSettings jwkFile = do
, _sendLoginEmails = LogEmailToConsole , _sendLoginEmails = LogEmailToConsole
, _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800" , _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
, _fileFolder = "data" , _fileFolder = "data"
, _cookieSettings = defaultCookieSettings -- TODO-SECURITY tune , _cookieSettings = defaultCookieSettings { cookieXsrfSetting = Just xsrfCookieSetting } -- TODO-SECURITY tune
, _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune , _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
} }
where
xsrfCookieSetting = defaultXsrfCookieSettings { xsrfExcludeGet = True }
......
src/Gargantext/Viz/Graph/Tools.hs
View file @ c3fec4af
...@@ -15,6 +15,8 @@ Portability : POSIX ...@@ -15,6 +15,8 @@ Portability : POSIX
module Gargantext.Viz.Graph.Tools module Gargantext.Viz.Graph.Tools
where where
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent (newEmptyMVar, takeMVar, putMVar, forkIO)
import Debug.Trace (trace) import Debug.Trace (trace)
import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode(..)) import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode(..))
import Data.Graph.Clustering.Louvain.CplusPlus (cLouvain) import Data.Graph.Clustering.Louvain.CplusPlus (cLouvain)
...@@ -68,11 +70,14 @@ cooc2graph threshold myCooc = do ...@@ -68,11 +70,14 @@ cooc2graph threshold myCooc = do
n' = Set.size $ Set.fromList $ as <> bs n' = Set.size $ Set.fromList $ as <> bs
ClustersParams rivers level = {-trace ("nodesApprox: " <> show nodesApprox) $-} clustersParams nodesApprox ClustersParams rivers level = {-trace ("nodesApprox: " <> show nodesApprox) $-} clustersParams nodesApprox
partitionsV <- liftIO newEmptyMVar
partitions <- case Map.size distanceMap > 0 of partitions' <- case Map.size distanceMap > 0 of
True -> trace ("level" <> show level) $ cLouvain level distanceMap True -> trace ("level" <> show level) $ cLouvain level distanceMap
False -> panic "Text.Flow: DistanceMap is empty" False -> panic "Text.Flow: DistanceMap is empty"
_ <- liftIO $ forkIO $ putMVar partitionsV partitions'
partitions <- liftIO $ takeMVar partitionsV
let bridgeness' = {-trace ("rivers: " <> show rivers) $-} let bridgeness' = {-trace ("rivers: " <> show rivers) $-}
bridgeness rivers partitions distanceMap bridgeness rivers partitions distanceMap
......
stack.yaml
View file @ c3fec4af
...@@ -7,7 +7,7 @@ packages: ...@@ -7,7 +7,7 @@ packages:
docker: docker:
enable: false enable: false
repo: 'fpco/stack-build:lts-14.6-garg' repo: 'fpco/stack-build:lts-14.27-garg'
run-args: run-args:
- '--publish=8008:8008' - '--publish=8008:8008'
......
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