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

README.md

@@ -72,7 +72,14 @@ stack install
 ~/.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
 stack --docker run gargantext-init -- gargantext.ini

devops/docker/Dockerfile

-from fpco/stack-build:lts-14.6
+from fpco/stack-build:lts-14.27
 
 RUN apt-get update && \
     apt-get install -y git libigraph0-dev && \

src/Gargantext/API.hs

@@ -208,7 +208,7 @@ type GargAPI' =
            -- auth and capabilities.
           :<|> GargPrivateAPI
 
-type GargPrivateAPI = SA.Auth '[SA.JWT] AuthenticatedUser :> GargPrivateAPI'
+type GargPrivateAPI = SA.Auth '[SA.JWT, SA.Cookie] AuthenticatedUser :> GargPrivateAPI'
 
 type GargAdminAPI
               -- Roots endpoint
@@ -239,11 +239,11 @@ type GargPrivateAPI' =
                            :> NodeAPI HyperdataAny
 
            -- Corpus endpoints
-           :<|> "corpus":> Summary "Corpus endpoint"
+           :<|> "corpus"   :> Summary "Corpus endpoint"
                            :> Capture "corpus_id" CorpusId
                            :> NodeAPI HyperdataCorpus
 
-           :<|> "corpus":> Summary "Corpus endpoint"
+           :<|> "corpus"   :> Summary "Corpus endpoint"
                            :> Capture "node1_id" NodeId
                            :> "document"
                            :> Capture "node2_id" NodeId
@@ -253,27 +253,29 @@ type GargPrivateAPI' =
                            :> Export.API
 
            -- Annuaire endpoint
-           :<|> "annuaire":> Summary "Annuaire endpoint"
+           :<|> "annuaire" :> Summary "Annuaire endpoint"
                            :> Capture "annuaire_id" AnnuaireId
                            :> NodeAPI HyperdataAnnuaire
 
            :<|> "annuaire" :> Summary "Contact endpoint"
                            :> Capture "annuaire_id" NodeId
-                           :> "contact" :> Capture "contact_id" NodeId
+                           :> "contact"
+                           :> Capture "contact_id" NodeId
                            :> NodeNodeAPI HyperdataContact
 
            -- Document endpoint
-           :<|> "document":> Summary "Document endpoint"
+           :<|> "document" :> Summary "Document endpoint"
                            :> Capture "doc_id" DocId
                            :> "ngrams" :> TableNgramsApi
 
         -- :<|> "counts" :> Stream GET NewLineFraming '[JSON] Count :> CountAPI
             -- TODO-SECURITY
            :<|> "count"    :> Summary "Count endpoint"
-                        :> ReqBody '[JSON] Query :> CountAPI
+                           :> ReqBody '[JSON] Query
+                           :> CountAPI
 
            -- Corpus endpoint --> TODO rename s/search/filter/g
-           :<|> "search":> Capture "corpus" NodeId
+           :<|> "search"   :> Capture "corpus" NodeId
                            :> SearchPairsAPI
 
            -- TODO move to NodeAPI?
@@ -296,7 +298,7 @@ type GargPrivateAPI' =
        --  :<|> "scraper" :> WithCallbacks ScraperAPI
        --  :<|> "new"  :> New.Api
 
-           :<|> "list" :> Summary "List export API"
+           :<|> "lists"  :> Summary "List export API"
                          :> Capture "listId" ListId
                          :> List.API
 
@@ -470,7 +472,7 @@ type Desc t n = Description (AppendSymbol (TypeName t) (AppendSymbol " | " n))
 swaggerDoc :: Swagger
 swaggerDoc = toSwagger (Proxy :: Proxy GargAPI)
   & 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.description ?~ "REST API specifications"
   -- & tags             .~ Set.fromList [Tag "Garg" (Just "Main perations") Nothing]

src/Gargantext/API/Corpus/New.hs

@@ -20,6 +20,7 @@ New corpus means either:
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE FlexibleContexts   #-}
 {-# LANGUAGE RankNTypes         #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Gargantext.API.Corpus.New
       where
@@ -77,10 +78,15 @@ instance Arbitrary Query where
 instance ToSchema Query where
   declareNamedSchema = genericDeclareNamedSchema (unPrefixSwagger "query_")
 
-type Api = Summary "New Corpus endpoint"
+------------------------------------------------------------------------
+
+type Api = PostApi
+        :<|> GetApi
+
+type PostApi = Summary "New Corpus endpoint"
              :> ReqBody '[JSON] Query
              :> Post '[JSON] CorpusId
-        :<|> Get '[JSON] ApiInfo
+type GetApi = Get '[JSON] ApiInfo
 
 -- | TODO manage several apis
 -- TODO-ACCESS
@@ -130,6 +136,7 @@ data WithForm = WithForm
   { _wf_filetype :: !FileType
   , _wf_data     :: !Text
   , _wf_lang     :: !(Maybe Lang)
+  , _wf_name     :: !Text
   } deriving (Eq, Show, Generic)
 
 makeLenses ''WithForm
@@ -241,7 +248,7 @@ addToCorpusWithForm :: FlowCmdM env err m
                     -> WithForm
                     -> (ScraperStatus -> m ())
                     -> m ScraperStatus
-addToCorpusWithForm cid (WithForm ft d l) logStatus = do
+addToCorpusWithForm cid (WithForm ft d l _n) logStatus = do
 
   printDebug "ft" ft
 

src/Gargantext/API/Ngrams.hs

@@ -39,6 +39,8 @@ module Gargantext.API.Ngrams
   , TableNgramsApiPost
 
   , getTableNgrams
+  , setListNgrams
+  , rmListNgrams
   , putListNgrams
   , putListNgrams'
   , tableNgramsPost
@@ -116,13 +118,14 @@ import Data.Map.Strict (Map)
 import qualified Data.Set as Set
 import Control.Category ((>>>))
 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.Reader
 import Control.Monad.State
 import Data.Aeson hiding ((.=))
 import Data.Aeson.TH (deriveJSON)
 import Data.Either(Either(Left))
+import Data.Either.Extra (maybeToEither)
 -- import Data.Map (lookup)
 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
 import Data.Swagger hiding (version, patch)
@@ -662,7 +665,7 @@ data Versioned a = Versioned
   { _v_version :: Version
   , _v_data    :: a
   }
-  deriving (Generic, Show)
+  deriving (Generic, Show, Eq)
 deriveJSON (unPrefix "_v_") ''Versioned
 makeLenses ''Versioned
 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
   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
 
 ngramsPatch :: Int -> NgramsPatch
@@ -852,6 +856,32 @@ addListNgrams listId ngramsType nes = do
     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
 -- the repo, they will be ignored.
 putListNgrams :: RepoCmdM env err m
@@ -1100,7 +1130,6 @@ getTableNgrams _nType nId tabType listId limit_ offset
 -- TODO: find a better place for the code above, All APIs stay here
 type QueryParamR = QueryParam' '[Required, Strict]
 
-
 data OrderBy = TermAsc | TermDesc | ScoreAsc | ScoreDesc
              deriving (Generic, Enum, Bounded, Read, Show)
 
@@ -1112,6 +1141,7 @@ instance FromHttpApiData OrderBy
     parseUrlPiece "ScoreDesc" = pure ScoreDesc
     parseUrlPiece _           = Left "Unexpected value of OrderBy"
 
+
 instance ToParamSchema OrderBy
 instance FromJSON  OrderBy
 instance ToJSON    OrderBy
@@ -1222,3 +1252,7 @@ instance Arbitrary NgramsRepoElement where
     where
       NgramsTable ns = mockTable
 
+--{-
+instance FromHttpApiData (Map NgramsType (Versioned NgramsTableMap))
+  where
+    parseUrlPiece x = maybeToEither x (decode $ cs x)

src/Gargantext/API/Ngrams/List.hs

@@ -12,6 +12,8 @@ Portability : POSIX
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes        #-}
@@ -21,40 +23,126 @@ Portability : POSIX
 module Gargantext.API.Ngrams.List
   where
 
-import Gargantext.Prelude
-import Gargantext.API.Ngrams
-import Servant
+import Control.Lens hiding (elements)
+import Control.Monad.IO.Class (liftIO)
+import Data.Aeson
 import Data.List (zip)
 import Data.Map (Map, toList, fromList)
-import Gargantext.Database.Types.Node
-import Gargantext.Database.Schema.Ngrams (NgramsType(..), ngramsTypes)
-import Gargantext.Database.Flow (FlowCmdM)
+import Data.Swagger (ToSchema, declareNamedSchema, genericDeclareNamedSchema)
+import Data.Text (Text, concat, pack)
+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.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 API = Get '[JSON] NgramsList
-      :<|> ReqBody '[JSON] NgramsList :> Put '[JSON] Bool
+------------------------------------------------------------------------
+type API =  Get '[HTML] (Headers '[Header "Content-Disposition" Text] NgramsList)
+       -- :<|> ReqBody '[JSON] NgramsList :> Post '[JSON] Bool
+       :<|> PostAPI
 
 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
+        => 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
-get lId = fromList
+get' lId = fromList
        <$> zip ngramsTypes
        <$> mapM (getNgramsTableMap lId) ngramsTypes
 
+------------------------------------------------------------------------
+
 -- TODO : purge list
-put :: FlowCmdM env err m
+post :: FlowCmdM env err m
     => ListId
     -> NgramsList
     -> m Bool
-put l m = do
+post l m  = do
   -- 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
   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

@@ -48,7 +48,7 @@ import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as L
 
 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 qualified Servant.Job.Core
 import Servant.Job.Async (newJobEnv, defaultSettings, HasJobEnv(..), Job)
@@ -106,9 +106,11 @@ devSettings jwkFile = do
     , _sendLoginEmails = LogEmailToConsole
     , _scrapydUrl = fromMaybe (panic "Invalid scrapy URL") $ parseBaseUrl "http://localhost:6800"
     , _fileFolder = "data"
-    , _cookieSettings = defaultCookieSettings -- TODO-SECURITY tune
+    , _cookieSettings = defaultCookieSettings { cookieXsrfSetting = Just xsrfCookieSetting } -- TODO-SECURITY tune
     , _jwtSettings = defaultJWTSettings jwk -- TODO-SECURITY tune
     }
+  where
+    xsrfCookieSetting = defaultXsrfCookieSettings { xsrfExcludeGet = True }
 
 
 

src/Gargantext/Viz/Graph/Tools.hs

@@ -15,6 +15,8 @@ Portability : POSIX
 module Gargantext.Viz.Graph.Tools
   where
 
+import Control.Monad.IO.Class (liftIO)
+import Control.Concurrent (newEmptyMVar, takeMVar, putMVar, forkIO)
 import Debug.Trace (trace)
 import Data.Graph.Clustering.Louvain.CplusPlus (LouvainNode(..))
 import Data.Graph.Clustering.Louvain.CplusPlus (cLouvain)
@@ -68,11 +70,14 @@ cooc2graph threshold myCooc = do
           n' = Set.size $ Set.fromList $ as <> bs
       ClustersParams rivers level = {-trace ("nodesApprox: " <> show nodesApprox) $-} clustersParams nodesApprox
 
-
-  partitions <- case Map.size distanceMap > 0 of
+  partitionsV <- liftIO newEmptyMVar
+  partitions' <- case Map.size distanceMap > 0 of
     True  -> trace ("level" <> show level) $ cLouvain level distanceMap
     False -> panic "Text.Flow: DistanceMap is empty"
 
+  _ <- liftIO $ forkIO $ putMVar partitionsV partitions'
+  partitions <- liftIO $ takeMVar partitionsV
+
   let bridgeness' = {-trace ("rivers: " <> show rivers) $-}
                     bridgeness rivers partitions distanceMap
 

stack.yaml

@@ -7,7 +7,7 @@ packages:
 
 docker:
   enable: false
-  repo: 'fpco/stack-build:lts-14.6-garg'
+  repo: 'fpco/stack-build:lts-14.27-garg'
   run-args:
     - '--publish=8008:8008'