Merge branch 'dev' of ssh://gitlab.iscpif.fr:20022/gargantext/haskell-gargantext into dev

src/Gargantext/API.hs

@@ -30,6 +30,8 @@ Thanks @yannEsposito for this.
 {-# LANGUAGE TemplateHaskell      #-}
 {-# LANGUAGE TypeOperators        #-}
 {-# LANGUAGE KindSignatures       #-}
+{-# LANGUAGE RankNTypes           #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -45,14 +47,16 @@ import           GHC.TypeLits (AppendSymbol, Symbol)
 
 import           Control.Lens
 import           Control.Exception (finally)
+import           Control.Monad.Except (withExceptT, ExceptT)
 import           Control.Monad.IO.Class (liftIO)
-import           Control.Monad.Reader (runReaderT)
+import           Control.Monad.Reader (ReaderT, runReaderT)
 import           Data.Aeson.Encode.Pretty (encodePretty)
 import qualified Data.ByteString.Lazy.Char8 as BL8
 import           Data.Swagger
 import           Data.Text (Text)
 import qualified Data.Text.IO as T
 --import qualified Data.Set as Set
+import           Data.Validity
 
 import           Network.Wai
 import           Network.Wai.Handler.Warp hiding (defaultSettings)
@@ -70,6 +74,7 @@ import           Text.Blaze.Html (Html)
 
 --import Gargantext.API.Swagger
 import Gargantext.Prelude
+import Gargantext.Core.Types (HasInvalidError(..))
 import Gargantext.API.FrontEnd (FrontEndAPI, frontEndServer)
 
 import Gargantext.API.Auth (AuthRequest, AuthResponse, auth)
@@ -84,8 +89,10 @@ import Gargantext.API.Node ( GargServer
                            , HyperdataCorpus
                            , HyperdataAnnuaire
                            )
+import Gargantext.Database.Schema.Node (HasNodeError(..), NodeError)
 --import Gargantext.Database.Node.Contact (HyperdataContact)
 import Gargantext.Database.Utils (HasConnection)
+import Gargantext.Database.Tree (HasTreeError(..), TreeError)
 import Gargantext.Database.Types.Node (NodeId, CorpusId, AnnuaireId)
 import Gargantext.API.Count  ( CountAPI, count, Query)
 import Gargantext.API.Search ( SearchAPI, search, SearchQuery)
@@ -115,6 +122,26 @@ import Network.HTTP.Types hiding (Query)
 
 import Gargantext.API.Settings
 
+data GargError
+  = GargNodeError NodeError
+  | GargTreeError TreeError
+  | GargInvalidError Validation
+  deriving (Show)
+
+makePrisms ''GargError
+
+instance HasNodeError GargError where
+  _NodeError = _GargNodeError
+
+instance HasInvalidError GargError where
+  _InvalidError = _GargInvalidError
+
+instance HasTreeError GargError where
+  _TreeError = _GargTreeError
+
+showAsServantErr :: Show a => a -> ServantErr
+showAsServantErr a = err500 { errBody = BL8.pack $ show a }
+
 fireWall :: Applicative f => Request -> FireWall -> f Bool
 fireWall req fw = do
     let origin = lookup "Origin" (requestHeaders req)
@@ -278,13 +305,16 @@ type API = SwaggerFrontAPI :<|> GargAPI :<|> Get '[HTML] Html
 ---------------------------------------------------------------------
 -- | Server declarations
 
-server :: (HasConnection env, HasRepo env, HasSettings env)
+server :: forall env. (HasConnection env, HasRepo env, HasSettings env)
        => env -> IO (Server API)
 server env = do
   -- orchestrator <- scrapyOrchestrator env
   pure $  swaggerFront
-     :<|> hoistServer (Proxy :: Proxy GargAPI) (`runReaderT` env) serverGargAPI
+     :<|> hoistServer (Proxy :: Proxy GargAPI) transform serverGargAPI
      :<|> serverStatic
+  where
+    transform :: forall a. ReaderT env (ExceptT GargError IO) a -> Handler a
+    transform = Handler . withExceptT showAsServantErr . (`runReaderT` env)
 
 serverGargAPI :: GargServer GargAPI
 serverGargAPI -- orchestrator

src/Gargantext/API/Ngrams.hs

@@ -37,7 +37,6 @@ module Gargantext.API.Ngrams
 -- import Debug.Trace (trace)
 import Prelude (Enum, Bounded, Semigroup(..), minBound, maxBound {-, round-}, error)
 -- import Gargantext.Database.Schema.User  (UserId)
-import Data.Functor (($>))
 import Data.Patch.Class (Replace, replace, Action(act), Applicable(..),
                          Composable(..), Transformable(..),
                          PairPatch(..), Patched, ConflictResolution,
@@ -55,9 +54,8 @@ import Data.Map.Strict (Map)
 import qualified Data.Set as Set
 import Control.Category ((>>>))
 import Control.Concurrent
-import Control.Lens (makeLenses, makePrisms, Getter, Prism', prism', Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^..), (^?), (+~), (%~), (%=), sumOf, at, _Just, Each(..), itraverse_, both, mapped, forOf_)
-import Control.Monad (guard)
-import Control.Monad.Error.Class (MonadError, throwError)
+import Control.Lens (makeLenses, makePrisms, Getter, Iso', iso, from, (.~), (?=), (#), to, folded, {-withIndex, ifolded,-} view, use, (^.), (^..), (^?), (+~), (%~), (%=), sumOf, at, _Just, Each(..), itraverse_, both, mapped, forOf_)
+import Control.Monad.Error.Class (MonadError)
 import Control.Monad.Reader
 import Control.Monad.State
 import Data.Aeson hiding ((.=))
@@ -82,7 +80,7 @@ import qualified Gargantext.Database.Schema.Ngrams as Ngrams
 -- import Gargantext.Database.Schema.NodeNgram hiding (Action)
 import Gargantext.Prelude
 -- import Gargantext.Core.Types (ListTypeId, listTypeId)
-import Gargantext.Core.Types (ListType(..), NodeId, ListId, CorpusId, Limit, Offset)
+import Gargantext.Core.Types (ListType(..), NodeId, ListId, CorpusId, Limit, Offset, HasInvalidError, assertValid)
 import Servant hiding (Patch)
 import System.FileLock (FileLock)
 import Test.QuickCheck (elements)
@@ -622,22 +620,6 @@ type TableNgramsApi = Summary " Table Ngrams API Change"
                       :> ReqBody '[JSON] (Versioned NgramsTablePatch)
                       :> Put     '[JSON] (Versioned NgramsTablePatch)
 
-data NgramError = UnsupportedVersion
-  deriving (Show)
-
-class HasNgramError e where
-  _NgramError :: Prism' e NgramError
-
-instance HasNgramError ServantErr where
-  _NgramError = prism' make match
-    where
-      err = err500 { errBody = "NgramError: Unsupported version" }
-      make UnsupportedVersion = err
-      match e = guard (e == err) $> UnsupportedVersion
-
-ngramError :: (MonadError e m, HasNgramError e) => NgramError -> m a
-ngramError nne = throwError $ _NgramError # nne
-
 {-
 -- TODO: Replace.old is ignored which means that if the current list
 -- `GraphTerm` and that the patch is `Replace CandidateTerm StopTerm` then
@@ -670,6 +652,7 @@ ngramsTypeFromTabType tabType =
       Institutes -> Ngrams.Institutes
       Terms      -> Ngrams.NgramsTerms
       _          -> panic $ lieu <> "No Ngrams for this tab"
+      -- ^ TODO: This `panic` would disapear with custom NgramsType.
 
 ------------------------------------------------------------------------
 data Repo s p = Repo
@@ -756,22 +739,6 @@ ngramsStatePatchConflictResolution _ngramsType _nodeId _ngramsTerm
   = (const ours, ours)
   -- undefined {- TODO think this through -}, listTypeConflictResolution)
 
-class HasInvalidError e where
-  _InvalidError :: Prism' e Validation
-
-instance HasInvalidError ServantErr where
-  _InvalidError = panic "error" {-prism' make match
-    where
-      err = err500 { errBody = "InvalidError" }
-      make _ = err
-      match e = guard (e == err) $> UnsupportedVersion-}
-
--- assertValid :: (MonadError e m, HasInvalidError e) => Validation -> m ()
--- assertValid v = when (not $ validationIsValid v) $ throwError $ _InvalidError # v
-
-assertValid :: MonadIO m => Validation -> m ()
-assertValid v = when (not $ validationIsValid v) $ fail $ show v
-
 -- Current state:
 --   Insertions are not considered as patches,
 --   they do not extend history,
@@ -828,8 +795,7 @@ putListNgrams listId ngramsType nes = do
 
 -- Apply the given patch to the DB and returns the patch to be applied on the
 -- client.
-tableNgramsPatch :: (HasNgramError err, HasInvalidError err,
-                     RepoCmdM env err m)
+tableNgramsPatch :: (HasInvalidError err, RepoCmdM env err m)
                  => CorpusId -> TabType -> ListId
                  -> Versioned NgramsTablePatch
                  -> m (Versioned NgramsTablePatch)
@@ -863,8 +829,17 @@ tableNgramsPatch _corpusId tabType listId (Versioned p_version p_table)
                 & r_state   %~ act p'
                 & r_history %~ (p' :)
           q'_table = q' ^. _PatchMap . at ngramsType . _Just . _PatchMap . at listId . _Just
+        {-
+        -- Ideally we would like to check these properties. However:
+        -- * They should be checked only to debug the code. The client data
+        --   should be able to trigger these.
+        -- * What kind of error should they throw (we are in IO here)?
+        -- * Should we keep modifyMVar?
+        -- * Should we throw the validation in an Exception, catch it around
+        --   modifyMVar and throw it back as an Error?
         assertValid $ transformable p q
         assertValid $ applicable p' (r ^. r_state)
+        -}
         pure (r', Versioned (r' ^. r_version) q'_table)
 
       saveRepo

src/Gargantext/API/Node.hs

@@ -44,7 +44,7 @@ import Gargantext.API.Metrics
 import Gargantext.API.Ngrams (TabType(..), TableNgramsApi, TableNgramsApiGet, tableNgramsPatch, getTableNgrams, HasRepo, QueryParamR)
 import Gargantext.API.Ngrams.Tools
 import Gargantext.API.Search ( SearchAPI, searchIn, SearchInQuery)
-import Gargantext.Core.Types (Offset, Limit, ListType(..))
+import Gargantext.Core.Types (Offset, Limit, ListType(..), HasInvalidError)
 import Gargantext.Core.Types.Main (Tree, NodeTree)
 import Gargantext.Database.Facet (FacetDoc , runViewDocuments, OrderBy(..),FacetChart,runViewAuthorsDoc)
 import qualified Gargantext.Database.Metrics as Metrics
@@ -74,11 +74,16 @@ import qualified Gargantext.Text.List.Learn as Learn
 import qualified Data.Vector as Vec
 --}
 
-type GargServer api = forall env m.
-    ( CmdM env ServantErr m
-    , HasRepo     env
+type GargServer api =
+  forall env err m.
+    ( CmdM env err m
+    , HasNodeError err
+    , HasInvalidError err
+    , HasTreeError err
+    , HasRepo env
     , HasSettings env
-    ) => ServerT api m
+    )
+    => ServerT api m
 
 -------------------------------------------------------------------
 -- TODO-ACCESS: access by admin only.

src/Gargantext/Core/Types.hs

@@ -20,9 +20,12 @@ module Gargantext.Core.Types ( module Gargantext.Core.Types.Main
                              , Term, Terms(..)
                              , TokenTag(..), POS(..), NER(..)
                              , Label, Stems
+                             , HasInvalidError(..), assertValid
                              ) where
 
-import GHC.Generics
+import Control.Lens (Prism', (#))
+import Control.Monad.Error.Class (MonadError, throwError)
+
 import Data.Aeson
 import Data.Semigroup
 import Data.Monoid
@@ -30,11 +33,13 @@ import Data.Set (Set, empty)
 --import qualified Data.Set as S
 
 import Data.Text (Text, unpack)
+import Data.Validity
 
 import Gargantext.Core.Types.Main
 import Gargantext.Database.Types.Node
 import Gargantext.Prelude
 
+import GHC.Generics
 ------------------------------------------------------------------------
 
 type Term  = Text
@@ -120,3 +125,11 @@ instance Monoid TokenTag where
 
   mconcat = foldl mappend mempty
 
+
+class HasInvalidError e where
+  _InvalidError :: Prism' e Validation
+
+assertValid :: (MonadError e m, HasInvalidError e) => Validation -> m ()
+assertValid v = when (not $ validationIsValid v) $ throwError $ _InvalidError # v
+-- assertValid :: MonadIO m => Validation -> m ()
+-- assertValid v = when (not $ validationIsValid v) $ fail $ show v

src/Gargantext/Database/Metrics.hs

@@ -31,12 +31,11 @@ import Gargantext.Database.Flow (getOrMkRootWithCorpus)
 import Gargantext.Database.Config (userMaster)
 import Gargantext.Prelude
 import Gargantext.Text.Metrics (scored, Scored(..), localMetrics, toScored)
-import Servant (ServantErr)
 import qualified Data.Map    as Map
 import qualified Data.Vector.Storable as Vec
 
 
-getMetrics' :: FlowCmdM env ServantErr m
+getMetrics' :: FlowCmdM env err m
             => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
             -> m (Map Text (ListType, Maybe Text), [Scored Text])
 getMetrics' cId maybeListId tabType maybeLimit = do
@@ -44,7 +43,7 @@ getMetrics' cId maybeListId tabType maybeLimit = do
   pure (ngs, scored myCooc)
 
 
-getMetrics :: FlowCmdM env ServantErr m
+getMetrics :: FlowCmdM env err m
             => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
             -> m (Map Text (ListType, Maybe Text), [Scored Text])
 getMetrics cId maybeListId tabType maybeLimit = do
@@ -57,7 +56,7 @@ getMetrics cId maybeListId tabType maybeLimit = do
   pure (ngs , toScored [metrics, Map.fromList $ map (\(a,b) -> (a, Vec.fromList [fst b])) $ Map.toList metrics'])
 
 
-getLocalMetrics  :: (FlowCmdM env ServantErr m)
+getLocalMetrics  :: (FlowCmdM env err m)
             => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
           -> m ( Map Text (ListType, Maybe Text)
                , Map Text (Maybe RootTerm)
@@ -68,7 +67,7 @@ getLocalMetrics cId maybeListId tabType maybeLimit = do
   pure (ngs, ngs', localMetrics myCooc)
 
 
-getNgramsCooc :: (FlowCmdM env ServantErr m)
+getNgramsCooc :: (FlowCmdM env err m)
             => CorpusId -> Maybe ListId -> TabType -> Maybe Limit
             -> m ( Map Text (ListType, Maybe Text)
                  , Map Text (Maybe RootTerm)
@@ -89,7 +88,7 @@ getNgramsCooc cId maybeListId tabType maybeLimit = do
 
 
 
-getNgrams :: (FlowCmdM env ServantErr m)
+getNgrams :: (FlowCmdM env err m)
             => CorpusId -> Maybe ListId -> TabType
             -> m (Map Text (ListType, Maybe Text), Map Text (Maybe RootTerm))
 getNgrams cId maybeListId tabType = do